Adding new row(s) with (possibly sum formula) in between rows in vba

Question

i have a table

fruits	price
apple	2000
apple	1400
orange	1000
orange	2500
grape	1000
grape	1200

and this is the goal

header 1	header 2
apple	2000
apple	1400
total of apple	sum apple or 3400
orange	1000
orange	2500
total of orange	sum orange or 3500
total of apple and orange	sum apple orange or 6900
grape	1000
grape	1200
total of grape	sum grape or 2200
grand total	sum of apple orange grape or 13800

the value of the added row can be formula of sum or the calculation from the vba

this is what i tried

Dim lastRow2 As Long
Dim newrow1 As Long, newrow2 As Long, newrow3 As Long, newrow4 as Long

Dim total1 As Long, total2 As Long, total3 As Long, total4 as Long
lastRow2 = DestinationWS.Cells(DestinationWS.Rows.Count, "B").End(xlUp).Row

    For i = 1 To lastRow2
        If WS.Cells(i, 2).Value = "apple" Then
            total1 = total1 + WS.Cells(i, 2).Value
            If newrow1 = 0 Then newrow1 = i
        ElseIf WS.Cells(i, 2).Value = "orange" Then
            total2 = total2 + WS.Cells(i, 2).Value
            If newrow2 = 0 Then newrow2 = i
        ElseIf WS.Cells(i, 2).Value = "grape" Then
            total3 = total3 + WS.Cells(i, 2).Value
            If newrow3 = 0 Then newrow3 = i
        End If
   Next i

   If newrow1 > 0 And newrow2 > 0 Then
        WS.Rows(newrow2).Insert Shift:=xlDown
        WS.Cells(newrow2, 1).Value = "total apple"
        WS.Cells(newrow2, 2).Value = total1
   End If
   
   If newrow2 > 0 And newrow3 > 0 Then
        WS.Rows(newrow3).Insert Shift:=xlDown
        WS.Cells(newrow3, 1).Value = "total orange"
        WS.Cells(newrow3, 2).Value = total2
   End If

   If newrow3 > 0 And newrow4 > 0 Then
        WS.Rows(newrow4).Insert Shift:=xlDown
        WS.Cells(newrow4, 1).Value = "total grape"
        WS.Cells(newrow4, 2).Value = total3
   End If

but it's really became messy and im confused where to add total of apple and orange and grand total any kind of suggestions are open! thank you :)

Answer 1

• Use Dictionary object to calculate summary.
• Dynamically generate subtotal category names instead of hardcoding them, so the code can support an extended list of fruits.

Option Explicit
Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sKey As String, sLastKey As String, iSum
    Dim arrData, arrRes, iR As Long, sList As String
    Set objDic = CreateObject("scripting.dictionary")
    ' Load data
    Set rngData = Range("A1").CurrentRegion.Offset(1)
    arrData = rngData.Value
    ReDim arrRes(UBound(arrData) * 2, 1)
    ' Header of output table
    arrRes(0, 0) = "Fruits"
    arrRes(0, 1) = "Sum"
    iR = 0
    ' Loop through each row
    For i = LBound(arrData) To UBound(arrData)
        sKey = arrData(i, 1)
        If objDic.exists(sKey) Then
            objDic(sKey) = objDic(sKey) + arrData(i, 2)
            iSum = iSum + arrData(i, 2)
            iR = iR + 1
            arrRes(iR, 0) = arrData(i, 1)
            arrRes(iR, 1) = arrData(i, 2)
        Else
            'Total for each kind of fruit
            If objDic.Count > 0 Then
                iR = iR + 1
                arrRes(iR, 0) = "Total of " & sLastKey
                arrRes(iR, 1) = "Sum " & sLastKey & " is " & objDic(sLastKey)
                'Sub total
                If objDic.Count > 1 Then
                    iR = iR + 1
                    sList = Join(objDic.Keys)
                    arrRes(iR, 0) = "Total of " & sList
                    arrRes(iR, 1) = "Sum " & sList & " is " & iSum
                End If
            End If
            objDic(sKey) = arrData(i, 2)
            sLastKey = sKey
            If Len(sKey) > 0 Then
                iR = iR + 1
                arrRes(iR, 0) = arrData(i, 1)
                arrRes(iR, 1) = arrData(i, 2)
                iSum = iSum + arrData(i, 2)
            End If
        End If
    Next i
    ' Write output to sheet
    arrRes(iR, 0) = "Grand Total"
    Range("D:E").Clear
    Range("D1").Resize(iR + 1, 2) = arrRes
End Sub

Microsoft documentation:

Dictionary object

Range.Resize property (Excel)

Range.CurrentRegion property (Excel)