vba help - Dictionary multiple Column Sum for same key

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
766
Office Version
  1. 2010
Platform
  1. Windows
Hi Team,

how to make multiple columns sum using dictionary.

Input Colums A,B and C are input Columns,
Expected Output Columns - G,H,I.

Below is input data with expected ouput in ghi columns

Book2
ABCDEFGHI
1NameCenturyFiftyDouble CenturyNameTotal CenturyTotal FiftyDouble Century
2Sachin10402Sachin30515
3Dhoni20251Dhoni20251
4Sachin20113Kohli30254
5Kohli30254
Sheet1




My Attempted Code, which works for extracting Single Columns
how to make dynamic code, so that It can store multiple columns, in dictionary Items with sum value.

VBA Code:
Sub SumUsing_Dictionary()

Dim dict As New Scripting.Dictionary
Dim i As Long
Dim cl As Range
Dim total As Long

Dim k As String
dict.RemoveAll

With dict
    For i = 2 To 5
            k = Cells(i, 1).Value  'Key
            total = Cells(i, 2).Value ' Total
    
        If Not .Exists(k) Then
                .Add k, total
            Else
                .Item(k) = .Item(k) + total
        End If
    Next i

End With



For Each cl In Range("F2", Range("F" & Rows.Count).End(xlUp))
         If dict.Exists(cl.Value) Then
                cl.Offset(, 1).Value = dict.Item(cl.Value)
          End If
Next cl


End Sub


Sub SumUsing_Dictionary_2()

Dim dict As New Scripting.Dictionary
Dim i As Long
Dim cl As Range
Dim total As Long


dict.RemoveAll
With dict
For Each cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         .Item(cl.Value) = .Item(cl.Value) + cl.Offset(, 1).Value
    Next cl
End With

For Each cl In Range("G2", Range("G" & Rows.Count).End(xlUp))
         If dict.Exists(cl.Value) Then
                cl.Offset(, 1).Value = dict.Item(cl.Value)
          End If
Next cl

End Sub



Thanks
mg
 

Some videos you may like

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,125
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
Sub Mallesh()
   Dim Cl As Range
   Dim Tmp As Variant
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Array(Cl.Offset(, 1).Value, Cl.Offset(, 2).Value, Cl.Offset(, 3).Value)
         Else
            Tmp = .Item(Cl.Value)
            Tmp(0) = Tmp(0) + Cl.Offset(, 1).Value
            Tmp(1) = Tmp(1) + Cl.Offset(, 2).Value
            Tmp(2) = Tmp(2) + Cl.Offset(, 3).Value
            .Item(Cl.Value) = Tmp
         End If
      Next Cl
      For Each Cl In Range("F2", Range("F" & Rows.Count).End(xlUp))
         If .Exists(Cl.Value) Then Cl.Offset(, 1).Resize(, 3).Value = .Item(Cl.Value)
      Next Cl
   End With
End Sub
 

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
766
Office Version
  1. 2010
Platform
  1. Windows
Hi Fluff,

Perfect !!!! it worked supert. millions of thanks for your help. 🕺 (y)



Thanks
mg
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,125
Office Version
  1. 365
Platform
  1. Windows
Glad to help & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,114,013
Messages
5,545,490
Members
410,686
Latest member
Fer9us
Top