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

?

 

[Nelson78]

@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

I'm trying to work with one more discriminating factor.

Something like this:

Sub DicCount2()

   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(, 3))
   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
   
     [COLOR="#FF0000"] If Not dic.exists(Ary(i, 1))(Ary(i, 2)) Then[/COLOR] dic.Add Ary(i, 3), CreateObject("scripting.dictionary")
      dic(Ary(i, 1))(Ary(i, 2))(Ary(i, 3)) = dic(Ary(i, 1))(Ary(i, 2))(Ary(i, 3)) + 1
    
   Next i
   

   For i = 2 To UBound(Ary)
      Ary(i, 4) = dic(Ary(i, 1))(Ary(i, 2))(Ary(i, 3))
   Next i

   Range("D1").Resize(UBound(Ary)).Value = Application.Index(Ary, 0, 4)

End sub

error run-time '13' type mismatch in the red line

 

[Fluff]

Can you please explain what you are trying to do?

 

[Nelson78]

Can you please explain what you are trying to do?

With one more column (the date).

https://imgur.com/a/RgcMvl8

For example, in D2: how many times occurs the association A2/B2/C2 ?

 

[Fluff]

How about

Sub DicCount2()

   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(, 3))
   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)).Add Ary(i, 2), CreateObject("scripting.dictionary")
         dic(Ary(i, 1))(Ary(i, 2)).Add Ary(i, 3), 1
      ElseIf Not dic(Ary(i, 1)).exists(Ary(i, 2)) Then
         dic(Ary(i, 1)).Add Ary(i, 2), CreateObject("scripting.dictionary")
         dic(Ary(i, 1))(Ary(i, 2)).Add Ary(i, 3), 1
      ElseIf Not dic(Ary(i, 1))(Ary(i, 2)).exists(Ary(i, 3)) Then
         dic(Ary(i, 1))(Ary(i, 2)).Add Ary(i, 3), 1
      Else
         dic(Ary(i, 1))(Ary(i, 2))(Ary(i, 3)) = dic(Ary(i, 1))(Ary(i, 2))(Ary(i, 3)) + 1
      End If
   Next i
   

   For i = 2 To UBound(Ary)
      Ary(i, 4) = dic(Ary(i, 1))(Ary(i, 2))(Ary(i, 3))
   Next i

   Range("D1").Resize(UBound(Ary)).Value = Application.Index(Ary, 0, 4)

End Sub

 

[Peter_SSs]

.. or if your columns are still disjoint (I've used columns C, F and AQ - with results in column AR) & again just using a single dictionary:

Sub Dict_Count_v3()
  Dim lr As Long, i As Long
  Dim dict As Object
  Dim x As Variant
  
  ActiveSheet.AutoFilterMode = False
  lr = Cells(Rows.Count, "C").End(xlUp).Row
  x = Application.Index(Range("C1:AQ" & lr).Value, Evaluate("row(2:" & lr & ")"), Array(1, 4, 41))
  Set dict = CreateObject("Scripting.Dictionary")
  dict.CompareMode = 1
  For i = 1 To UBound(x, 1)
    dict(x(i, 1) & "|" & x(i, 2) & "|" & x(i, 3)) = dict(x(i, 1) & "|" & x(i, 2) & "|" & x(i, 3)) + 1
  Next i
  For i = 1 To UBound(x, 1)
    x(i, 1) = dict(x(i, 1) & "|" & x(i, 2) & "|" & x(i, 3))
  Next i
  Range("AR2:AR" & lr).Value = Application.Index(x, 0, 1)
End Sub

Excel Workbook
	C	F	AQ	AR
1	Date	Colour	Code	Results
2	24/09/2017	RED	AAAAA	2
3	24/09/2017	GREEN	AAAAA	2
4	24/09/2017	YELLOW	AAAAA	1
5	24/09/2017	RED	EE	1
6	24/09/2017	GREEN	AAAAA	2
7	24/09/2017	YELLOW	ZZ	1
8	24/09/2017	RED	AAAAA	2
9	24/09/2017	YELLOW	BBB	1
10	24/09/2017	GREEN	BBB	2
11	24/09/2017	RED	BBB	1
12	24/09/2017	GREEN	BBB	2
13	24/09/2017	YELLOW	EE	1
14	25/09/2017	RED	BBB	2
15	25/09/2017	RED	BBB	2
16	25/09/2017	RED	CCCCCCCC	4
17	25/09/2017	RED	CCCCCCCC	4
18	25/09/2017	RED	CCCCCCCC	4
19	25/09/2017	RED	CCCCCCCC	4
20	25/09/2017	YELLOW	XXXXXXXXXX	1
21	25/09/2017	GREEN	AAAAA	3
22	25/09/2017	GREEN	AAAAA	3
23	25/09/2017	GREEN	AAAAA	3
Sheet2