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

 

[EFANYoutube]

Sorry but you are going to have to be more clear

 

[Marc L]

It's clear enough but this solution belongs to good readers only …​

​

According to Excel basics like any Excel beginner operating manually a VBA demonstration to paste to the Sheet2 worksheet module :​

Sub Demo1()
        Dim F$, V, N&
        UsedRange.Clear
        Application.ScreenUpdating = False
    With Sheets("Sheet1").UsedRange.Rows
            F = Replace$("=COUNTIFS(Sheet1!$A$2:$A$#,$A2,Sheet1!$B$2:$B$#,B$1)+COUNTIFS(Sheet1!$A$2:$A$#,$A2,Sheet1!$C$2:$C$#,B$1)", "#", .Count)
        With .Item("2:" & .Count).Columns
           .Item(2).Copy [B1]
            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)
            If UBound(V) > -1 Then Cells(UsedRange.Rows.Count + 1, 2).Resize(UBound(V) + 1).Value2 = Application.Transpose(V)
            UsedRange.RemoveDuplicates 1, 2
            [B1].Resize(, UsedRange.Rows.Count).Value2 = Application.Transpose(UsedRange)
            Range("B2:B" & UsedRange.Rows.Count).Clear
           .Item(1).Copy [A2]
        End With
    End With
        UsedRange.Columns(1).RemoveDuplicates 1, 1
        UsedRange.HorizontalAlignment = xlCenter
    With [B2].Resize(UsedRange.Rows.Count - 1, UsedRange.Columns.Count - 1)
        .Formula = F
        .Formula = .Value2
    End With
        Application.ScreenUpdating = True
End Sub

 

[Marc L]

​

As using an external object like Dictionary is not always the way to go and here a single Dictionary is necessary only …​

 

[BSALV]

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 ?

 

[Marc L]

I am using a dictionary to count data. My friend came up with the code below. I am just learning

Your friend did not catch the easy logic !​

​

A single Dictionary VBA demonstration to paste to the Sheet2 worksheet module :​

Sub Demo2()
  Const D = "¤", S = "Sheet1"
    Dim H, W, V, R&, C%, K$
        UsedRange.Clear
    With Sheets(S).Range("A2:C" & Sheets(S).UsedRange.Rows.Count).Columns
        H = .Item("B:C").Value2
        W = .Value2
       .Item(1).Copy [A2]
    End With
        UsedRange.RemoveDuplicates 1, 2
    With CreateObject("Scripting.Dictionary")
        For Each V In H:  .Item(V) = Null:  Next
        If .Exists(0) Then .Remove 0
        H = .Keys()
       .RemoveAll
    For R = 1 To UBound(W)
    For C = 2 To 3
        K = W(R, 1) & D & W(R, C)
       .Item(K) = .Item(K) + 1
    Next C, R
        V = UsedRange.Value2
        ReDim W(1 To UBound(V), UBound(H))
    For R = 1 To UBound(V)
    For C = 0 To UBound(H)
        K = V(R, 1) & D & H(C)
        If .Exists(K) Then W(R, C) = .Item(K)
    Next C, R
       .RemoveAll
    End With
        [B1].Resize(, C).Value2 = H
        [B2].Resize(R - 1, C).Value2 = W
        UsedRange.HorizontalAlignment = xlCenter
        Application.ScreenUpdating = True
End Sub

 

[Marc L]

​

Oups ! I forgot at the beginning of Demo2 just after the codeline UsedRange.Clear this one : Application.ScreenUpdating = False​

 

[BSALV]

@Marc L, 3 * Usedrange without a worksheet,
in general a difficult approach.

 

[Marc L]

Usedrange without a worksheet,
in general a difficult approach.

Very not a concern if the VBA procedure is located as expected in the Sheet2 worksheet module !​

Like this the code is lighter : no need to use some useless worksheet object variable or any direct worksheet reference for Sheet2 …​

 

[Marc L]

As the worksheet codenames are used in the original post​

so if really the VBA procedure must be in a general / standard module rather than a worksheet class module this is my Demo2 revamped :​

Sub Demo2r()
  Const D = "¤"
    Dim H, W, V, R&, C%, K$
        Sheet2.UsedRange.Clear
        Application.ScreenUpdating = False
    With Sheet1.Range("A2:C" & Sheet1.UsedRange.Rows.Count).Columns
        H = .Item("B:C").Value2
        W = .Value2
       .Item(1).Copy Sheet2.[A2]
    End With
        Sheet2.UsedRange.RemoveDuplicates 1, 2
    With CreateObject("Scripting.Dictionary")
        For Each V In H:  .Item(V) = Null:  Next
        If .Exists(0) Then .Remove 0
        H = .Keys()
       .RemoveAll
    For R = 1 To UBound(W)
    For C = 2 To 3
        K = W(R, 1) & D & W(R, C)
       .Item(K) = .Item(K) + 1
    Next C, R
        V = Sheet2.UsedRange.Value2
        ReDim W(1 To UBound(V), UBound(H))
    For R = 1 To UBound(V)
    For C = 0 To UBound(H)
        K = V(R, 1) & D & H(C)
        If .Exists(K) Then W(R, C) = .Item(K)
    Next C, R
       .RemoveAll
    End With
    With Sheet2
        .[B1].Resize(, C).Value2 = H
        .[B2].Resize(R - 1, C).Value2 = W
        .UsedRange.HorizontalAlignment = xlCenter
    End With
        Application.ScreenUpdating = True
End Sub