VBA Dictionary Multiple Items to Count Col B and Col C

[Stephen_IV]

I need VBA assistance. I am using a dictionary to count data. My friend came up with the code below. I am just learning. I have my key as Column A I need to have the item be column B and C to put the output that i need. I am stuck. Any help would be appreciated.

VBA Dic Item Mult Cols.xlsm
	A	B	C
1	Facility	Sanction Type (primary)	Sanction Type (secondary)
2	144020	1070	0
3	147816	1071	0
4	143419	1010	0
5	143419	1064	9999
6	141416	1010	0
7	147611	1020	0
8	147611	1020	0
9	147611	1061	0
10	147611	1020	1054
11	141120	1069	0
12	142520	1065	0
13	147916	1066	0
14	144219	1076	1000
15	142919	1070	0
16	142919	1065	0
17	147611	1020	1010
18	147611	1020	1010
Sheet1

VBA Dic Item Mult Cols.xlsm A B C D E F G H I J K L M N 1 1070 1071 1010 1064 1020 1061 1069 1065 1066 1076 9999 1054 1000 2 144020 1 0 0 0 0 0 0 0 0 0 0 0 0 3 147816 0 1 0 0 0 0 0 0 0 0 0 0 0 4 143419 0 0 1 1 0 0 0 0 0 0 1 0 0 5 141416 0 0 1 0 0 0 0 0 0 0 0 0 0 6 147611 0 0 2 0 5 1 0 0 0 0 0 1 0 7 141120 0 0 0 0 0 0 1 0 0 0 0 0 0 8 142520 0 0 0 0 0 0 0 1 0 0 0 0 0 9 147916 0 0 0 0 0 0 0 0 1 0 0 0 0 10 144219 0 0 0 0 0 0 0 0 0 1 0 0 1 11 142919 1 0 0 0 0 0 0 1 0 0 0 0 0 Sheet2

Option Explicit
Public Sub main()
Dim lastrow As Long
Dim r As Range
lastrow = Cells(Rows.count, "A").End(xlUp).Row
Set r = Sheets("Sheet1").Range("A2:A" & lastrow)
Dim dic As New Dictionary
Dim dic2 As New Dictionary
Dim dic3 As New Dictionary
Dim dic4 As New Dictionary
Dim dic5 As New Dictionary
Dim xcell
Dim cell
Dim i As Long
Dim j As Long
Dim n As Long
Dim y
    For Each cell In r
        If Not dic.Exists(Trim(cell.Text)) Then
            dic.Add Trim(cell.Text), New Dictionary
        End If
        
        Set dic2 = dic(Trim(cell.Text))
        
        If Not dic2.Exists(Trim(cell.Offset(0, 1).Text)) Then
            dic2(Trim(cell.Offset(0, 1).Text)) = 0
        End If
        
        If Not dic5.Exists(Trim(cell.Offset(0, 2).Text)) Then
            dic5(Trim(cell.Offset(0, 2).Text)) = 0
        End If
        
        dic2(Trim(cell.Offset(0, 1).Text)) = dic2(Trim(cell.Offset(0, 1).Text)) + 1
        dic5(Trim(cell.Offset(0, 2).Text)) = dic5(Trim(cell.Offset(0, 2).Text)) + 1
        dic3(Trim(cell.Offset(0, 1).Text)) = Trim(cell.Offset(0, 1).Text)
        dic5(Trim(cell.Offset(0, 2).Text)) = Trim(cell.Offset(0, 2).Text)
    Next

j = 2
    For Each cell In dic3.Keys
        Sheet2.Cells(1, j).Value = cell
        j = j + 1
    Next

i = 2
    For Each cell In dic.Keys
        j = 2
        Sheet2.Cells(i, 1).Value = cell

Set dic4 = dic(cell)
Dim k
    
    For Each k In dic3.Keys
    Dim count As Integer
    count = 0
        If (dic4.Exists(k)) Then count = dic4(k)
        Sheet2.Cells(i, j).Value = count
        j = j + 1
    Next
        i = i + 1
    Next
End Sub

 

[Stephen_IV]

If you compare "Demo2bs" and "BSALV", both dictionaries provide the row and column for the array.
BSALV adds as key the attribute "facility" or "sanction", normally unnecessary because the 1st is 6 the other 4 characters long, but in case of ... .
PS. I added comments so that rookies can understand what happens.

BSALV! Thank you so much!!! I appreciate all of your help and guidance!!!

 

[Marc L]

This is simplified and ready for an unknown number of columns.
With the dictionary, you know the row and column within the array

Demo2bs does not need to use Redim Preserve (one of the simplifications for your original procedure)​

as the maximum array size can be easily calculated …​

​

The reason why I used in post #16 this codeline : ReDim V(1 To UBound(W), 1 To UBound(W) * 2) …​

Or better the post #18 little optimization …​

 

[BSALV]

My point doesn't concern that redim, that's just a small detail, that one is quickly oversized, no problem.
If so then i only have to adjust this line

ReDim Result(UBound(a), UBound(a) * ubound(a,2)

I have problems to read your mind, what 're doing in that macro, and i'm a skilled VBA-user.

 

[Marc L]

Maybe 'cause I can't see why you over complicated in your original procedure​

with Redim and Split(Replace(Join(Filter(dict.keys, rather than directly allocating the result array​

according to the OP has written : « I am just learning » …​

 

[BSALV]

okay, that was complicated.
That is now in row0 and column0 of that array.
It's better, you made your point for that one.