Using dictionary to get sub-totals...The fastest way to subtotals using VBA

Hello All,

Today we are going to look at how to get subtotals of a data using VBA.

Consider following example ;

We are having "serial number" in column "A", "Person name" in column "B" and "Amount" in column "C". We need to get person wise total amount in column H. Let see how we can achieve this using dictionary structures in fastest way.

Refer to both the subroutines below. They both do the same thing in different way.

Sub GetSubTotalsUsingDictionaryStructure()

Dim i As Integer
Dim j As Integer

'DECLARE AND SET AN OBJECT OF A DICTIONARY
Dim dic_MySubTotal As Scripting.Dictionary
Set dic_MySubTotal = New Scripting.Dictionary

'LOOP THROUGH THE DATA AND LOADS THE DICTIONARY
For i = 2 To Sheet1.Range("A" & Sheet1.Cells.Rows.Count - 1).End(xlUp).Row
    If Sheet1.Range("B" & i).Value <> "" Then
        If Not dic_MySubTotal.Exists(Trim(Sheet1.Range("B" & i).Value)) Then
            'ADDS THE VALUE TO DICTIONARY IF NOT ALREADY PRESENT
            dic_MySubTotal.Add Trim(Sheet1.Range("B" & i).Value), Sheet1.Range("C" & i).Value
        Else
            'IF ALREADY PRESENT, SUMS UP THE EARLIER VALUE WITH CURRENT VALUE AND REPLACE THE ITEM
            dic_MySubTotal.Item(Trim(Sheet1.Range("B" & i).Value)) = _
                dic_MySubTotal.Item(Trim(Sheet1.Range("B" & i).Value)) + (Sheet1.Range("C" & i).Value)
        End If
    End If
Next

j = 2   'Initiate the row variable

For Each Var In dic_MySubTotal.Keys
    With Sheet1
        .Range("H" & j).Value = Var                         'GETS PERSON NAME
        .Range("I" & j).Value = dic_MySubTotal.Item(Var)    'GETS ITs TOTAL FROM DICTIONARY
    End With
Next

'RELEASES THE OBJECTS
dic_MySubTotal.RemoveAll
Set dic_MySubTotal = Nothing

End Sub

'-------------------------------------------------------------------------------------------------------------------

Sub GetSubTotalsUsingDictionaryStructure_1()

Dim i           As Integer
Dim j           As Integer
Dim int_LastRw  As Integer

'DECLARE AND SET AN OBJECT OF A DICTIONARY
Dim dic_MySubTotal As Scripting.Dictionary
Set dic_MySubTotal = New Scripting.Dictionary

'LOOP THROUGH THE DATA AND LOADS THE DICTIONARY
For i = 2 To Sheet1.Range("A" & Sheet1.Cells.Rows.Count - 1).End(xlUp).Row
    If Sheet1.Range("B" & i).Value <> "" Then
        If Not dic_MySubTotal.Exists(Trim(Sheet1.Range("B" & i).Value)) Then
            'GETS THE LAST ROW OF SUBTOTAL TABLE
            int_LastRw = Sheet1.Range("H" & Sheet1.Cells.Rows.Count - 1).End(xlUp).Row + 1
            'ADDS THE VALUE TO DICTIONARY IF NOT ALREADY PRESENT AS A KEY .....
            'DESTINATION TABLE ROW NUMBER AS ITEM
            dic_MySubTotal.Add Trim(Sheet1.Range("B" & i).Value), int_LastRw
            'ADDS THE DISTINCT VALUE TO DESTINATION TABLE
            Sheet1.Range("H" & int_LastRw).Value = Trim(Sheet1.Range("B" & i).Value)    'PERSON NAME
            Sheet1.Range("I" & int_LastRw).Value = Trim(Sheet1.Range("C" & i).Value)    'VALUE
        Else
            'IF ALREADY PRESENT, SUMS UP THE EARLIER VALUE WITH CURRENT VALUE AND REPLACE THE ITEM
            'GETS THE ROW OF SAME PERSON IN DESTINATION TABLE
            j = dic_MySubTotal.Item(Trim(Sheet1.Range("B" & i).Value))
            'ADDS THE AMOUNT TO DESTINATION TABLE CURRESPONDING LINE
            Sheet1.Range("I" & j).Value = Sheet1.Range("I" & j).Value + _
                                          Sheet1.Range("C" & i).Value
        End If
    End If
Next

'RELEASES THE OBJECTS
dic_MySubTotal.RemoveAll
Set dic_MySubTotal = Nothing

End Sub

Attached is the sample workbook with this code. Click here to open the workbook.

Note: You can also use the code to get distinct values from data with minor modifications.

Thanks,

xploreVBA