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]

here i used 1 dictionary for the equivalent of both your facility and your sanction and the counters in an array

Transpose data in Excel

Hi Everyone, I have some complex data in a table I want to transpose in excel. In the table below I want take the 'element' column and transpose it so each individual element is listed as a column number per sample tag. The first image is how the data is currently presented and the second...

www.mrexcel.com

interested ?

Yes I am.

 

[Stephen_IV]

Marc L, thank you so much for giving me another approach and it works well. I apprecite your help! True, my friend happens to make thinks difficut to comprehend.

 

[Marc L]

In post #3 Demo1 this single codeline V = Filter(.Parent.Evaluate(Replace("TRANSPOSE(IF(#>0,#))", "#", .Item(3).Address)), False, False)​

can replace this block :​

            V = Application.Transpose(.Item(3))
        For N = 1 To UBound(V)
            If V(N) = 0 Then V(N) = False
        Next
            V = Filter(V, False, False)

 

[BSALV]

Sub BSALV()
     Dim Result()
     Set dict = CreateObject("Scripting.dictionary")
     a = Sheets("blad2").Range("A1").CurrentRegion.Value        'your data
     ReDim Result(1 To UBound(a), 1 To 3)                       'initialise result-array

     For i = 2 To UBound(a)                                     'loop through your data
          s1 = "Facility:" & a(i, 1)
          If Not dict.exists(s1) Then i1 = i1 + 1: dict.Add s1, i1: Result(i1, 1) = a(i, 1)     'does this faclilty exist in the dictionary ? if not add to dictionary and array
          For j = 2 To 3                                        'loop through the sanctions
               If a(i, j) <> 0 Then                             'there is a sanction
                    s2 = "Sanction:" & a(i, j)
                    If Not dict.exists(s2) Then i2 = i2 + 1: dict.Add s2, i2     'if sanction doesn't exist in dictionary, increment i2 and add as item
                    If UBound(Result, 2) < i2 + 1 Then ReDim Preserve Result(1 To UBound(Result), 1 To i2 + 1)     'if number of columns of Result not enough, add 1
                    r = dict(s1): k = dict(s2) + 1: Result(r, k) = Result(r, k) + 1     'increment right element within Result
               End If
          Next
     Next

     fl = Split(Replace(Join(Filter(dict.keys, "sanction", 1, vbTextCompare), "|"), "sanction:", "", , , vbTextCompare), "|")     'filter all sanctions & delete all strings "Sanction:"

     With Range("E1")                                           'outputrange
          .Resize(100, 100).ClearContents                       'clearcontents in a greater range
          .Offset(, 1).Resize(, UBound(fl) + 1).Value = fl      'write the unique sanctions
          With .Offset(1).Resize(i1, i2 + 1)
               .Value = Result                                  'write a fraction of "Result"
               With .EntireColumn
                    .AutoFit                                    'adjust coluumnwidth
                    .HorizontalAlignment = xlCenter             'center
               End With
          End With
     End With
End Sub

 

[Stephen_IV]

Great! Thanks to both of you! BSALV & Marc L thanks for taking the time to add your post and for helping me!

 

[Marc L]

Another Dictionary demonstration - same way as BSALV but simplified - to paste to a general / standard module :​

Sub Demo2bs()
    Dim F&, S%, W, V, L&, R&, K%, C%
        F = 1
        S = 1
        W = Sheet1.UsedRange.Value2
        ReDim V(1 To UBound(W), 1 To UBound(W) * 2)
    With CreateObject("Scripting.Dictionary")
        For L = 2 To UBound(W)
            If .Exists(W(L, 1)) Then R = .Item(W(L, 1)) Else F = F + 1: .Add W(L, 1), F: R = F: V(R, 1) = W(L, 1)
        For K = 2 To UBound(W, 2)
            If W(L, K) Then If .Exists(W(L, K)) Then C = .Item(W(L, K)): V(R, C) = V(R, C) + 1 _
                                                Else S = S + 1: .Add W(L, K), S: V(1, S) = W(L, K): V(R, S) = 1
        Next K, L
            .RemoveAll
    End With
    With Sheet2
        .UsedRange.Clear
        .[A1].Resize(F, S).Value2 = V
'        .UsedRange.Columns.AutoFit
        .UsedRange.HorizontalAlignment = xlCenter
    End With
End Sub

 

[Stephen_IV]

Nice!!! Thank you!!

 

[Marc L]

​

Little optimization for Demo2bs in case of more than 3 columns in Sheet1 : ReDim V(1 To UBound(W), 1 To UBound(W) * (UBound(W, 2) - 1))​

 

[BSALV]

BSALV but simplified

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

Sub BSALV()
     Dim Result()
     Set dict = CreateObject("Scripting.dictionary")
     a = Sheets("blad2").Range("A1").CurrentRegion.Value        'your data (unknown number of columns !)
     ReDim Result(UBound(a), UBound(a))                         'initialise result-array

     For I = 2 To UBound(a)                                     'loop through your data
          s1 = "Facility:" & a(I, 1)
          If Not dict.exists(s1) Then i1 = i1 + 1: dict.Add s1, i1: Result(i1, 0) = a(I, 1)     'does this faclilty exist in the dictionary ? if not, increment i1, add to dictionary and column 0 of the array
          For J = 2 To UBound(a, 2)                             'loop through the sanctions
               If a(I, J) <> 0 Then                             'there is a sanction
                    s2 = "Sanction:" & a(I, J)
                    If Not dict.exists(s2) Then
                         If UBound(Result, 2) = i2 Then ReDim Preserve Result(UBound(Result), i2 + 10)     'if number of columns of Result not enough, add 10 at once
                         i2 = i2 + 1: dict.Add s2, i2: Result(0, i2) = a(I, J)     'if sanction doesn't exist in dictionary, increment i2, add to dictionary and row 0 of the array
                    End If
                    r = dict(s1): k = dict(s2): Result(r, k) = Result(r, k) + 1     'increment right element within Result, row and column are found in the dictionary
               End If
          Next
     Next
     Result(0, 0) = "Facility/Sanction"

     With Range("AA1")                                          'outputrange (adapt address to your situation)
          .CurrentRegion.ClearContents                          'clearcontents in a greater range
          With .Resize(i1 + 1, i2 + 1)
               .Value = Result                                  'write a fraction of "Result"
               .EntireColumn.AutoFit
               .HorizontalAlignment = xlCenter
          End With
     End With
End Sub

 

[BSALV]

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.