Using Dictionary As Item Within Another Dictionary to Count Unique Values - vba

Question

Here is what I am trying to accomplish:
I have an ID in Column DA. I have a product in Column CB. I want to count the number of unique products for each ID (ID can have multiple lines). I then want to write the number of unique products to a new column (DB).
My logic was to write two dictionaries. The "main" dictionary would be keyed to the ID and the second dictionary would be keyed to my products. In the main dictionary, if the key exists I would retrieve the item into a dict object, if it doesn't exist then I'd re-write the main dictionary.
After this, I was thinking of using .count function to tell me how many unique values existed for each ID.
I have been trying to adapt some code to fit my needs. Here is what I have currently:
Sub Find_Unique_Product_Number()
Dim LastRow As Long
LastRow = Worksheets("Orders").Range("A" & Rows.Count).End(xlUp).Row
adata = Worksheets("Orders").Range("A1:DB" & LastRow)
Set dicTwoProds = CreateObject("Scripting.Dictionary") 'Late binding creation of dictionary
For LastRow = LBound(adata, 1) To UBound(adata, 1)
sKey1 = adata(LastRow, 80)
If Not dicTwoProds.Exists(sKey) Then
Set dicItem = CreateObject("Scripting.Dictionary")
dicTwoProds.Add sKey1, aItem
sKey1 = Worksheets("Orders").Range("CB2:CB" & LastRow) 'Product
dicTwoProdsItem.Add sKey1, ""
Else
Set dicItem = dicTwoProd.Item(sKey)
sKey2 = Worksheets("Orders").Range("CB2:CB" & LastRow) 'Product
If Not dicItem.Exists(sKey2) Then
dicItem.Add sKey2, ""
dicTwoProds.Item(sKey) = aItem
End If
End If
Next
End Sub
Currently this code throws an "object required" error on this line: dicTwoProdsItem.Add sKey1, ""
I am guessing part of my issue is how I am using .range on the sKey lines? I am unsure of how that syntax should be.
I am not sure how writing the .count results to the sheet would work at all yet.
I do have an array formula that does what I need which is this:
'=SUM(IF(DA5=DA2:DA100,1/ (COUNTIFS(DA2:DA100,DA5,CB2:CB100,CB2:CB100)),0))
The formula is extremely slow which is part of the reason I wanted to use dictionaries. If the dictionary solution does not work, I would be interested in assistance with the syntax for using VBA to place the array formula into Column DB on my worksheet.
All data is on the same worksheet in the described scenario.
Cheers!

Answer 1

You can use a single Dictionary to count the number of unique products for each ID.
The trick is to concatenate the id with the product to create a unique key:
Dim dict As Object, lastRow As Long, r As Long, ids(), products(), dupIds()
Set dict = CreateObject("Scripting.Dictionary")
lastRow = Worksheets("Orders").Cells(Rows.Count, 1).End(xlUp).Row
ids = Worksheets("Orders").Range("DA2:DA" & lastRow).Value
products = Worksheets("Orders").Range("CB2:CB" & lastRow).Value
' map the id to each unique id/product '
For r = LBound(ids) To UBound(ids)
dict(ids(r, 1) & products(r, 1)) = CStr(ids(r, 1))
Next
' map the count of products to each unique id '
dupIds = dict.Items
dict.RemoveAll
For r = LBound(dupIds) To UBound(dupIds)
dict(dupIds(r)) = dict(dupIds(r)) + 1
Next
' build the column holding the count of products '
For r = LBound(ids) To UBound(ids)
products(r, 1) = dict(CStr(ids(r, 1)))
Next
Worksheets("Orders").Range("DB2:DB" & lastRow).Value = products

Answer 2

If I'm understanding you correctly something like this should work.
(Simplified for a 2-column dataset)
Sub Find_Unique_Product_Number()
Dim dict As Object, i As Long, id, prod, adata, k, k2
Dim rngDest As Range
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Orders")
adata = Worksheets("Orders").Range("A1:B" & _
.Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
For i = LBound(adata, 1) To UBound(adata, 1)
id = adata(i, 1)
prod = adata(i, 2)
If Len(id) > 0 And Len(prod) > 0 Then
'New id? Add as key with empty dictionary
If Not dict.exists(id) Then dict.Add id, CreateObject("Scripting.Dictionary")
'increment the count for this combination
dict(id)(prod) = dict(id)(prod) + 1
End If
Next
'EDIT: output the counts
Set rngDest = Worksheets("Summary").Range("A2")
For Each k In dict.keys
For Each k2 In dict(k).keys
rngDest.Resize(1, 3).Value = Array(k, k2, dict(k)(k2))
Set rngDest = rngDest.Offset(1, 0)
Next k2
Next
End Sub