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
