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

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
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
89
sijpie
sijpie
P
  • Question Question
How to pass variable between subs that are stored as array element through CreateObject("Scripting.Dictionary")
Replies
1
Views
462
Micron
M
Saher Naji
  • Question Question
VBA Code Issue on Mac Platform (working perfectly on Windows)
Replies
4
Views
551
Cristian Buse
C
O
  • Solved
VBA Code to Find Duplicate Values in a Range and Add a Number at the End
2
Replies
12
Views
598
OilEconomist
O
rjplante
  • Solved
Loop Count Math issue
Replies
6
Views
322
Akuini
Akuini

Forum statistics

Threads
1,223,244
Messages
6,170,976
Members
452,372
Latest member
Natalie18

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