VBA: apply dictionary to count

[Nelson78]

Hello everybody.

I would like to improuve my ability to use dictionary, but unfortunately I have problem in understanding how they work.

For example, in the case below, the result in column C has to be the number of different values in column B for each value in column A. (You can see the result on column C in gray).

https://imgur.com/a/sHEh2Uc

I've tried this way:

Sub count()

Dim s1
Dim lr As Long, i As Long, n As Long
Dim rng As Range
Dim x, dict, it

Set s1 = Sheets("Sheet 1")

s1.AutoFilterMode = False
lr = s1.Cells(Rows.count, 1).End(xlUp).Row
x = s1.Range("A2:A" & lr)

Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
    dict.Item(x(i, 1)) = ""
Next i

For Each it In dict.keys

and then?
Something like

.AutoFilter 1, it

?

 

[Fluff]

How about

Sub DicCount()
   Dim Ary As Variant
   Dim i As Long
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   Ary = Range("A1", Range("A" & Rows.count).End(xlUp).Offset(, 2))
   For i = 2 To UBound(Ary)
      If Not Dic.exists(Ary(i, 1)) Then Dic.Add Ary(i, 1), CreateObject("scripting.dictionary")
      Dic(Ary(i, 1))(Ary(i, 2)) = Dic(Ary(i, 1))(Ary(i, 2)) + 1
   Next i
   For i = 2 To UBound(Ary)
      Ary(i, 3) = Dic(Ary(i, 1))(Ary(i, 2))
   Next i
   Range("C1").Resize(UBound(Ary)).Value = Application.Index(Ary, 0, 3)
End Sub

 

[Peter_SSs]

Here is another way to consider. Instead of using a "dictionary of dictionaries" as Fluff has done, this one uses string values in a single dictionary to determine the counts.

Sub Dict_Count()
  Dim lr As Long, i As Long
  Dim dict As Object
  Dim x As Variant
  Dim s As String
  
  ActiveSheet.AutoFilterMode = False
  lr = Cells(Rows.Count, 1).End(xlUp).Row
  x = Range("A2:B" & lr).Value
  Set dict = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(x, 1)
    s = "|" & x(i, 2) & "|"
    If InStr(1, dict(x(i, 1)), s) = 0 Then dict(x(i, 1)) = dict(x(i, 1)) & s
  Next i
  For i = 1 To UBound(x, 1)
    x(i, 1) = UBound(Split(dict(x(i, 1)), "||")) + 1
  Next i
  Range("C2:C" & lr).Value = Application.Index(x, 0, 1)
End Sub

Edit: On looking more closely, I thinks Fluff's code is doing a different job to the one asked.

 

[MickG]

Another option:-

[COLOR=navy]Sub[/COLOR] MG18Sep17
[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]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
 [COLOR=navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
            [COLOR=navy]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR=navy]Then[/COLOR]
  '[COLOR=green][B]Creates new Dictionary Object for each unique value in "A"[/B][/COLOR]
                [COLOR=navy]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            [COLOR=navy]End[/COLOR] If
      '[COLOR=green][B]Creates Sub dictionarys for column "A" // "B"[/B][/COLOR]
        [COLOR=navy]If[/COLOR] Not Dic(Dn.Value).exists(Dn.Offset(, 1).Value) [COLOR=navy]Then[/COLOR]
                Dic(Dn.Value).Add (Dn.Offset(, 1).Value), ""
       [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
   
   '[COLOR=green][B]Loop through data again to find count  "A/B) data[/B][/COLOR]
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        Dn.Offset(, 2).Value = Dic(Dn.Value).Count
    [COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[Fluff]

@Peter_SSs
You are quite right, it is.

Here is an modified version

Sub DicCount()
   Dim Ary As Variant
   Dim i As Long
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   Ary = Range("A1", Range("A" & Rows.count).End(xlUp).Offset(, 2))
   For i = 2 To UBound(Ary)
      If Not Dic.exists(Ary(i, 1)) Then Dic.Add Ary(i, 1), CreateObject("scripting.dictionary")
      Dic(Ary(i, 1))(Ary(i, 2)) = Dic(Ary(i, 1))(Ary(i, 2)) + 1
   Next i
   For i = 2 To UBound(Ary)
      Ary(i, 3) = Dic(Ary(i, 1)).count
   Next i
   Range("C1").Resize(UBound(Ary)).Value = Application.Index(Ary, 0, 3)
End Sub

 

[Nelson78]

How about

Sub DicCount()
   Dim Ary As Variant
   Dim i As Long
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   Ary = Range("A1", Range("A" & Rows.count).End(xlUp).Offset(, 2))
   For i = 2 To UBound(Ary)
      If Not Dic.exists(Ary(i, 1)) Then Dic.Add Ary(i, 1), CreateObject("scripting.dictionary")
      Dic(Ary(i, 1))(Ary(i, 2)) = Dic(Ary(i, 1))(Ary(i, 2)) + 1
   Next i
   For i = 2 To UBound(Ary)
      Ary(i, 3) = Dic(Ary(i, 1))(Ary(i, 2))
   Next i
   Range("C1").Resize(UBound(Ary)).Value = Application.Index(Ary, 0, 3)
End Sub

Thank's to the 3 contributions, they are all ok.

It is certainly clearer than before.

Anyway, now I'm trying to perform some real task, unsuccessfully.

For example, taking as example the post #2 , I can't achieve with the columns scattered in the sheet.


Suppose column A becomes column M, column B becomes column H, and the result has to be written in column AL.

This doesn't work.

dim count2

   Dim Ary As Variant
   Dim i As Long
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   Ary = Range("M1", Range("M" & Rows.Count).End(xlUp).Offset(, 2))
   For i = 2 To UBound(Ary)
      If Not Dic.exists(Ary(i, 9)) Then Dic.Add Ary(i, 9), CreateObject("scripting.dictionary")
      Dic(Ary(i, 14))(Ary(i, 9)) = Dic(Ary(i, 14))(Ary(i, 9)) + 1
   Next i
   For i = 2 To UBound(Ary)
      Ary(i, 39) = Dic(Ary(i, 14))(Ary(i, 9))
   Next i
   Range("AL1").Resize(UBound(Ary)).Value = Application.Index(Ary, 0, 39) 

End sub

 

[Fluff]

First off, the code that you have tried to modify, does not do what your image showed you wanted (as pointed out by Peter).
So do you want a count of how many times Green & AAAA occur, or how many unique values you have where col A is Green?

 

[Nelson78]

First off, the code that you have tried to modify, does not do what your image showed you wanted (as pointed out by Peter).
So do you want a count of how many times Green & AAAA occur, or how many unique values you have where col A is Green?

Situation like this.

https://imgur.com/a/eSQE30o

Now I'm focusing on your post #2 : the scheme is "how many times Green & AAAA occur?"

 

[Fluff]

How about

Sub DicCount()
   Dim Ary As Variant
   Dim i As Long
   Dim dic As Object
   
   Set dic = CreateObject("scripting.dictionary")
   Ary = Range("H1", Range("H" & Rows.Count).End(xlUp).Offset(, 30))
   For i = 2 To UBound(Ary)
      If Not dic.exists(Ary(i, 6)) Then dic.Add Ary(i, 6), CreateObject("scripting.dictionary")
      dic(Ary(i, 6))(Ary(i, 1)) = dic(Ary(i, 6))(Ary(i, 1)) + 1
   Next i
   For i = 2 To UBound(Ary)
      Ary(i, 30) = dic(Ary(i, 6))(Ary(i, 1))
   Next i
   Range("AL1").Resize(UBound(Ary)).Value = Application.Index(Ary, 0, 30)
End Sub

 

[Peter_SSs]

Situation like this.

https://imgur.com/a/eSQE30o

Now I'm focusing on your post #2 : the scheme is "how many times Green & AAAA occur?"

My suggestion again uses a single dictionary rather than a dictionary of dictionaries.

Other things different with this code ..
a) It would count "BBB" & "Red" as belonging with "BBB" & "red". Not sure if you need or want that but if the entries are manual it might help with typing errors. If you want those pairs counted separately then remove the dict.CompareMode = 1 line from the code.
b) If your columns are very spread out and you have large data, this only reads the 2 columns of interest into the array (x) rather than all the columns from the first one until the result column. Starting from column H, the two columns you are interested in are column numbers 1 and 6 so you can adjust those two numbers along with "H" & "M" if you are dealing with different columns in the future.

Sub Dict_Count_v2()
  Dim lr As Long, i As Long
  Dim dict As Object
  Dim x As Variant
  
  ActiveSheet.AutoFilterMode = False
  lr = Cells(Rows.Count, "H").End(xlUp).Row
  x = Application.Index(Range("H1:M" & lr).Value, Evaluate("row(2:" & lr & ")"), Array(1, 6))
  Set dict = CreateObject("Scripting.Dictionary")
  dict.CompareMode = 1
  For i = 1 To UBound(x, 1)
    dict(x(i, 1) & "|" & x(i, 2)) = dict(x(i, 1) & "|" & x(i, 2)) + 1
  Next i
  For i = 1 To UBound(x, 1)
    x(i, 1) = dict(x(i, 1) & "|" & x(i, 2))
  Next i
  Range("AL2:AL" & lr).Value = Application.Index(x, 0, 1)
End Sub