vba - Dictionary/Collection

Mallesh23

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

I am using below code for extracting Unique list and making their Sum.
it works got this solution in this forum only.

Now my task is in Column H Contains list of player Name
and I want make sum of these players sixes in Column I from Column B.

Looking solution in dictionary/Collection. Just for learning purpose. Thanks.

Thanks in advance !

VBA Code:
Option Explicit
Sub Dictionary()
   Dim Ary As Variant
   Dim i As Long
   
   Ary = Range("A2", Range("A" & Rows.Count).End(xlUp).Offset(, 1))
   With CreateObject("Scripting.dictionary")
      For i = 1 To UBound(Ary)
         If Not .exists(Ary(i, 1)) Then
            .Add Ary(i, 1), Ary(i, 2)
         Else
            .Item(Ary(i, 1)) = .Item(Ary(i, 1)) + Ary(i, 2)
         End If
      Next i
      Range("D2").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .items))
   End With

Regards,
mg
 

Attachments

  • Input&Output Snapshot.PNG
    Input&Output Snapshot.PNG
    32 KB · Views: 18

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
How about
VBA Code:
Sub Mallesh()
   Dim Ary As Variant
   Dim i As Long
   Dim Cl As Range
   
   Ary = Range("A2", Range("A" & Rows.Count).End(xlUp).Offset(, 1))
   With CreateObject("Scripting.dictionary")
      For i = 1 To UBound(Ary)
         If Not .Exists(Ary(i, 1)) Then
            .Add Ary(i, 1), Ary(i, 2)
         Else
            .Item(Ary(i, 1)) = .Item(Ary(i, 1)) + Ary(i, 2)
         End If
      Next i
      Range("D2").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .items))
      For Each Cl In Range("H3", Range("H" & Rows.Count).End(xlUp))
         If .Exists(Cl.Value) Then Cl.Offset(, 1) = .Item(Cl.Value)
      Next Cl
   End With
End Sub
 
Upvote 0
FWIW, for this sort of use, there is no need to check whether a particular item already exists in the dictionary either when entering values or when extracting them.
For example, I think you will find this does the same job.

VBA Code:
Sub Mallesh_v2()
   Dim Ary As Variant
   Dim i As Long
   Dim Cl As Range
   
   Ary = Range("A2", Range("A" & Rows.Count).End(xlUp).Offset(, 1))
   With CreateObject("Scripting.dictionary")
      For i = 1 To UBound(Ary)
            .Item(Ary(i, 1)) = .Item(Ary(i, 1)) + Ary(i, 2)
      Next i
      Range("D2").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .items))
      For Each Cl In Range("H3", Range("H" & Rows.Count).End(xlUp))
         Cl.Offset(, 1) = .Item(Cl.Value)
      Next Cl
   End With
End Sub
 
Upvote 0
Hi Peter and Fluff,

Got solution as expected, Superrrrbb ! Many many thanks both of you!!!...?


Regards,
mg
 
Upvote 0
Glad you got a successful outcome. Thanks for letting us know. :)
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,981
Members
448,538
Latest member
alex78

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