Loops in Dictionary VBA

C

chriscorpion786

Board Regular
Joined
Apr 3, 2011
Messages
112
Office Version
  1. 365
Platform
  1. Windows
Hi Everbody,

I have done the summary using Dictionary in VBA, but i have many loops in my code. Is there a shorter method that I can use or nest the loops one inside the other.
Secondly , I am looking for a solution to summarize the data by name and by Location, 2 criterias using the same code with Dictionary.
I have put the sample below. How can I attach a file, if anyone needs to see the file.
Kindly provide a solution.

[TABLE="width: 767"]
<tbody>[TR]
[TD]Name[/TD]
[TD]CAT[/TD]
[TD]Sales[/TD]
[TD]Location[/TD]
[TD]Name[/TD]
[TD]Totals[/TD]
[TD][/TD]
[TD]CAT[/TD]
[TD]Totals[/TD]
[TD][/TD]
[TD]LOCATION[/TD]
[TD]Totals[/TD]
[/TR]
[TR]
[TD]Chris[/TD]
[TD]FHR[/TD]
[TD="align: right"]27[/TD]
[TD]U.K[/TD]
[TD]Chris[/TD]
[TD="align: right"]9408[/TD]
[TD][/TD]
[TD]FHR[/TD]
[TD="align: right"]15168[/TD]
[TD][/TD]
[TD]U.K[/TD]
[TD="align: right"]10987[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]MHR[/TD]
[TD="align: right"]25[/TD]
[TD]U.K[/TD]
[TD]Mike[/TD]
[TD="align: right"]3712[/TD]
[TD][/TD]
[TD]MHR[/TD]
[TD="align: right"]15680[/TD]
[TD][/TD]
[TD]US[/TD]
[TD="align: right"]8817[/TD]
[/TR]
[TR]
[TD]Ali[/TD]
[TD]FHR[/TD]
[TD="align: right"]39[/TD]
[TD]U.K[/TD]
[TD]Ali[/TD]
[TD="align: right"]12928[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]CHINA[/TD]
[TD="align: right"]11044[/TD]
[/TR]
[TR]
[TD]Davis[/TD]
[TD]MHR[/TD]
[TD="align: right"]14[/TD]
[TD]U.K[/TD]
[TD]Davis[/TD]
[TD="align: right"]4800[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]MHR[/TD]
[TD="align: right"]33[/TD]
[TD]US[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Chris[/TD]
[TD]MHR[/TD]
[TD="align: right"]41[/TD]
[TD]CHINA[/TD]
[TD][/TD]
[TD][/TD]
[TD]U.K[/TD]
[TD]US[/TD]
[TD]CHINA[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Ali[/TD]
[TD]FHR[/TD]
[TD="align: right"]20[/TD]
[TD]U.K[/TD]
[TD][/TD]
[TD]Chris[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Davis[/TD]
[TD]FHR[/TD]
[TD="align: right"]22[/TD]
[TD]US[/TD]
[TD][/TD]
[TD]Mike[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Ali[/TD]
[TD]FHR[/TD]
[TD="align: right"]14[/TD]
[TD]CHINA[/TD]
[TD][/TD]
[TD]Ali[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Ali[/TD]
[TD]FHR[/TD]
[TD="align: right"]17[/TD]
[TD]U.K[/TD]
[TD][/TD]
[TD]Davis[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Chris[/TD]
[TD]FHR[/TD]
[TD="align: right"]45[/TD]
[TD]U.K[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Ali[/TD]
[TD]MHR[/TD]
[TD="align: right"]24[/TD]
[TD]CHINA[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Davis[/TD]
[TD]MHR[/TD]
[TD="align: right"]39[/TD]
[TD]U.K[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Ali[/TD]
[TD]FHR[/TD]
[TD="align: right"]26[/TD]
[TD]CHINA[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Code: 
Sub SummaryCategoriesinDictionary()


Dim Catdict As Dictionary
Set Catdict = New Dictionary
Dim Namedict As Dictionary
Set Namedict = New Dictionary
Dim Locdict As Dictionary
Set Locdict = New Dictionary


Dim lastrow As Long
Dim x As Long
Dim key As Variant
Dim name As String
Dim cat As String
Dim value As Integer
Dim location As String




Range("E1:L5").ClearContents
lastrow = Range("A2", Range("A2").End(xlDown)).Rows.Count
lastrow = lastrow + 1


For x = 2 To lastrow


name = Cells(x, 1).value
cat = Cells(x, 2).value
location = Cells(x, 4).value
value = Cells(x, 3).value


Namedict(name) = Namedict(name) + value
Catdict(cat) = Catdict(cat) + value
Locdict(location) = Locdict(location) + value
Next x


'For Names
x = 2
For Each key In Namedict.Keys
Range("E1").value = "Name"
Range("F1").value = "Totals"


Cells(x, 5).value = key
Cells(x, 6).value = Namedict(key)


x = x + 1
Next key


'For Category
x = 2
For Each key In Catdict.Keys


Range("H1").value = "CAT"
Range("I1").value = "Totals"


Cells(x, 8).value = key
Cells(x, 9).value = Catdict(key)


x = x + 1
Next key


'For Location
x = 2
For Each key In Locdict.Keys


Range("K1").value = "LOCATION"
Range("L1").value = "Totals"


Cells(x, 11).value = key
Cells(x, 12).value = Locdict(key)


x = x + 1
Next key




End Sub
 
Last edited by a moderator:

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
Try this for the Name/Location code.
Results start "E2"
Code: 
[COLOR=navy]Sub[/COLOR] MG23May01
    [COLOR=navy]Dim[/COLOR] Dn          [COLOR=navy]As[/COLOR] Range
    [COLOR=navy]Dim[/COLOR] Rng         [COLOR=navy]As[/COLOR] Range
    [COLOR=navy]Dim[/COLOR] Dic         [COLOR=navy]As[/COLOR] Object
    [COLOR=navy]Dim[/COLOR] k           [COLOR=navy]As[/COLOR] Variant
    [COLOR=navy]Dim[/COLOR] p           [COLOR=navy]As[/COLOR] Variant
    [COLOR=navy]Dim[/COLOR] c           [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
    [COLOR=navy]Dim[/COLOR] Ac          [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
 [COLOR=navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
  [COLOR=navy]With[/COLOR] CreateObject("Scripting.Dictionary")
     .CompareMode = 1
   [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
           [COLOR=navy]If[/COLOR] Not .Exists(Dn.Offset(, 3).value) [COLOR=navy]Then[/COLOR]
               .Add (Dn.Offset(, 3).value), .Count
            [COLOR=navy]End[/COLOR] If
            [COLOR=navy]If[/COLOR] Not Dic.Exists(Dn.value) [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] Dic(Dn.value) = CreateObject("Scripting.Dictionary")
            [COLOR=navy]End[/COLOR] If
        
           [COLOR=navy]If[/COLOR] Not Dic(Dn.value).Exists(Dn.Offset(, 3).value) [COLOR=navy]Then[/COLOR]
                Dic(Dn.value).Add (Dn.Offset(, 3).value), Dn.Offset(, 2)
           [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] Dic(Dn.value).Item(Dn.Offset(, 3).value) = _
                Union(Dic(Dn.value).Item(Dn.Offset(, 3).value), Dn.Offset(, 2))
            [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
   
  
    ReDim Ray(1 To Rng.Count, 1 To .Count + 1)
    c = 1
    
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] Dic.Keys
        c = c + 1
          For Each p In Dic(k) 
              Ray(c, 1) = k
               Ray(1, .Item(p) + 2) = p
               Ray(c, .Item(p) + 2) = Application.Sum(Dic(k).Item(p))
          [COLOR=navy]Next[/COLOR] p
   
    [COLOR=navy]Next[/COLOR] k
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Range("E1").Resize(c, UBound(Ray, 2))
   .value = Ray
   .Borders.Weight = 2
   .Columns.AutoFit
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
What does the initial data look like?
 
Upvote 0
This should do the whole thing starting "E4".
Code: 
[COLOR=navy]Sub[/COLOR] MG23May52
    [COLOR=navy]Dim[/COLOR] Dn          [COLOR=navy]As[/COLOR] Range
    [COLOR=navy]Dim[/COLOR] Rng         [COLOR=navy]As[/COLOR] Range
    [COLOR=navy]Dim[/COLOR] Dic         [COLOR=navy]As[/COLOR] Object
    [COLOR=navy]Dim[/COLOR] k           [COLOR=navy]As[/COLOR] Variant
    [COLOR=navy]Dim[/COLOR] p           [COLOR=navy]As[/COLOR] Variant
    [COLOR=navy]Dim[/COLOR] c           [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
    [COLOR=navy]Dim[/COLOR] Ac          [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
    [COLOR=navy]Dim[/COLOR] RngAc       [COLOR=navy]As[/COLOR] Range
    [COLOR=navy]Dim[/COLOR] rAc         [COLOR=navy]As[/COLOR] Range
    [COLOR=navy]Dim[/COLOR] R           [COLOR=navy]As[/COLOR] Range
    [COLOR=navy]Dim[/COLOR] col         [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
    [COLOR=navy]Dim[/COLOR] oMax        [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
 [COLOR=navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
  [COLOR=navy]With[/COLOR] CreateObject("Scripting.Dictionary")
     .CompareMode = 1
   col = 1
   [COLOR=navy]Set[/COLOR] RngAc = Range("A1,B1,D1")
    ReDim Ray(1 To Rng.Count, 1 To 9)
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] rAc [COLOR=navy]In[/COLOR] RngAc
    
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] rAc.Resize(Rng.Count)
            [COLOR=navy]If[/COLOR] Not .Exists(R.value) [COLOR=navy]Then[/COLOR]
                c = c + 1
                oMax = Application.Max(oMax, c)
                .Add (R.value), Cells(R.Row, 3)
                Ray(c, col) = R.value: Ray(c, col + 1) = .Item(R.value)
            [COLOR=navy]Else[/COLOR]
               .Item(R.value) = .Item(R.value) + Cells(R.Row, 3)
                Ray(c, col + 1) = .Item(R.value)
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR] R
            col = col + 3: c = 0
           .RemoveAll
    [COLOR=navy]Next[/COLOR] rAc
   
   [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
           [COLOR=navy]If[/COLOR] Not .Exists(Dn.Offset(, 3).value) [COLOR=navy]Then[/COLOR]
               .Add (Dn.Offset(, 3).value), .Count
            [COLOR=navy]End[/COLOR] If
            [COLOR=navy]If[/COLOR] Not Dic.Exists(Dn.value) [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] Dic(Dn.value) = CreateObject("Scripting.Dictionary")
            [COLOR=navy]End[/COLOR] If
           [COLOR=navy]If[/COLOR] Not Dic(Dn.value).Exists(Dn.Offset(, 3).value) [COLOR=navy]Then[/COLOR]
                Dic(Dn.value).Add (Dn.Offset(, 3).value), Dn.Offset(, 2)
           [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] Dic(Dn.value).Item(Dn.Offset(, 3).value) = _
                Union(Dic(Dn.value).Item(Dn.Offset(, 3).value), Dn.Offset(, 2))
            [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn

    ReDim Preserve Ray(1 To Rng.Count, 1 To .Count + 10)
       c = 1
       oMax = Application.Max(oMax, c)
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] Dic.Keys
        c = c + 1
          [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] p [COLOR=navy]In[/COLOR] Dic(k)
              Ray(c, 10) = k
               Ray(1, .Item(p) + 11) = p
               Ray(c, .Item(p) + 11) = Application.Sum(Dic(k).Item(p))
          [COLOR=navy]Next[/COLOR] p
    [COLOR=navy]Next[/COLOR] k
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Range("E1").Resize(oMax, UBound(Ray, 2))
   .value = Ray
   .Borders.Weight = 2
   .Columns.AutoFit
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
@Norie, I assume the sample data is the first range in the OP. That's why I asked about a pivot table, all this dictionary stuff looks awfully hard work to me!
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA code for adding new group of columns with 3 condictions from 2 dictionary and 1 array Then fill in data from value from original columns
Replies
1
Views
127
sijpie
sijpie
WERNER SLABBERT
  • Question Question
Run-time error 70 after code changed
Replies
3
Views
118
RoryA
RoryA
P
  • Question Question
How to pass variable between subs that are stored as array element through CreateObject("Scripting.Dictionary")
Replies
1
Views
522
Micron
M
Z
  • Question Question
VBA Complex Organizational Loop
Replies
1
Views
50
HighAndWilder
H
Saher Naji
  • Question Question
VBA Code Issue on Mac Platform (working perfectly on Windows)
Replies
4
Views
666
Cristian Buse
C

Forum statistics

Threads
1,224,823
Messages
6,181,175
Members
453,021
Latest member
Justyna P

Share this page

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