vba help - Dictionary multiple Column Sum for same key

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
976
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
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
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
 
Upvote 0
Hi Fluff,

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



Thanks
mg
 
Upvote 0
Glad to help & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,567
Messages
6,114,344
Members
448,570
Latest member
rik81h

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top