Excel VBA Macro to Auto Insert row and insert Total and sum

Question

I am using the below code to insert total in the rows based on the Serial Number in Row A starting from Row 6, there are more than 5000 rows in a sheet. But when there are two serial numbers like in this example A15 and A16, the below code doesn't add a new row Total below the A15. it inserted the total in A17 and inserted a blank row in A14. instead of inserting total in A16 and the last total in A17.

Before enter image description here

Result I want After enter image description here

I tried the code, I want little tweak in the code.

Sub InsertTotals()

   Dim Rng As Range
   
   With Range("A7:A" & Range("G" & Rows.Count).End(xlUp).Row)
      .SpecialCells(xlConstants).EntireRow.Insert
   End With
   
   With Range("G6", Range("G" & Rows.Count).End(xlUp))
      For Each Rng In .SpecialCells(xlConstants).Areas
         If Rng.Offset(Rng.Count - 1).Resize(1).Value = "Total" Then Rng.Offset(Rng.Count - 1).Resize(1).EntireRow.Delete
         Rng.Offset(Rng.Count).Resize(1).Value = "Total"
         With Rng.Offset(Rng.Count, 1).Resize(1, 2)
            .Formula = "=sum(" & Rng.Offset(, 1).Address(False, False) & ")"
         End With
      Next Rng
   End With
End Sub

Please help to change the code

Answer 1

Below script doesn't insert rows as your expected.

   With Range("A7:A" & Range("G" & Rows.Count).End(xlUp).Row)
      .SpecialCells(xlConstants).EntireRow.Insert
   End With

Pls try

Sub InsertTotals()
    Const S_CELL = "A6"  ' top-left cell of the table
    ' load data into an array
    Dim arrData
    arrData = Range(S_CELL, Cells(Rows.Count, "I").End(xlUp)).Value
    ' output array
    Dim arrRes(): ReDim arrRes(1 To UBound(arrData) * 2, 1 To UBound(arrData, 2))
    Dim SumA As Double, SumB As Double, i As Long, j As Long, iR As Long
    ' loop through data rows
    For i = 1 To UBound(arrData)
        If Len(arrData(i, 1)) > 0 Then ' new Serial
            If i > 1 Then ' populate Total row
                iR = iR + 1
                arrRes(iR, 7) = "Total"
                arrRes(iR, 8) = SumA
                arrRes(iR, 9) = SumB
            End If
            ' init. total of Qty
            SumA = arrData(i, 8)
            SumB = arrData(i, 9)
        Else ' get the total of Qty
            SumA = arrData(i, 8) + SumA
            SumB = arrData(i, 9) + SumB
        End If
        ' populate with source data row
        iR = iR + 1
        For j = 1 To UBound(arrData, 2)
            arrRes(iR, j) = arrData(i, j)
        Next
    Next
    ' Total row for the last Serial
    iR = iR + 1
    arrRes(iR, 7) = "Total"
    arrRes(iR, 8) = SumA
    arrRes(iR, 9) = SumB
    ' Write output to sheet
    Range(S_CELL).Resize(iR, UBound(arrData, 2)).Value = arrRes
End Sub