Script that uses dictionary to get count of unique values in a multiple columns

[kbishop94]

here is the code that I currently use (I got it here with some help ~2 years ago.)

It captures unique values in column C and then gets a count of those unique values.

It works great.

Dim Cl As Range
Dim Cnt, TmpA, TmpB
Dim i As Long, X As Long
' get a count of all unique values in column C (starting at row 1)
With CreateObject("scripting.dictionary")
    For Each Cl In Worksheets("HELPER").Range("C1", Worksheets("HELPER").Range("C" & Rows.Count).End(xlUp))
        If Not .Exists(Cl.Value) Then
            .Add Cl.Value, 1
        Else
            .Item(Cl.Value) = .Item(Cl.Value) + 1
        End If
    Next Cl
ReDim Cnt(0 To .Count - 1, 0 To 1)
   For i = 0 To .Count - 1
      Cnt(i, 0) = .keys()(i)
      Cnt(i, 1) = .Items()(i)
   Next i
End With
For i = LBound(Cnt, 1) To UBound(Cnt, 1) - 1
   For X = i + 1 To UBound(Cnt, 1)
      If Cnt(i, 1) < Cnt(X, 1) Then
         TmpA = Cnt(X, 0)
         TmpB = Cnt(X, 1)
         Cnt(X, 0) = Cnt(i, 0)
         Cnt(X, 1) = Cnt(i, 1)
         Cnt(i, 0) = TmpA
         Cnt(i, 1) = TmpB
      End If
   Next X
Next i
' take the data that was tallied from above and paste it onto the worksheet: "HELPER1" starting at A1
Worksheets("HELPER1").Range("A" & Rows.Count).End(xlUp).Offset(0).Resize(UBound(Cnt) + 1, 2).Value = Cnt

My question is, if I want to get a count/tally of unique values in other columns (the above code only addresses a single column... column 'C' in this case), can the above procedure be modified to capture not only column C, but also columns D and E?

Here is the original data that is located on the spreadsheet "HELPER" before the script is executed:

Here is what the above code that I posted returns (the code captures each unique value found in column 'C' and then provides a tally for each of those unique values and then posts that value in the adjacent cell):

But here is what I am would like it to do (do not only column C, but also column D and E in the same manner):

Can this be done (more easily or efficiently) with one procedure, or am I better off just having three separate procedures that capture and tally the three separate columns?

(I dont have a problem doing it that way, if I have to... but I am going to have alot of procedures in order to capture and tally all the required data that I am after.)

Thanks for any help or suggestions!

 

[DanteAmor]

Try this

Sub count_unique()
  Dim a As Variant, b As Variant, c As Variant, i As Long
  Dim dic1 As Object, dic2 As Object, dic3 As Object
  
  a = Sheets("HELPER").Range("C1:E" & Sheets("HELPER").Range("C" & Rows.Count).End(xlUp).Row).Value2
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set dic3 = CreateObject("Scripting.Dictionary")
  dic1.CompareMode = vbTextCompare
  dic2.CompareMode = vbTextCompare
  dic3.CompareMode = vbTextCompare
  
  For i = 1 To UBound(a)
    dic1(a(i, 1)) = dic1(a(i, 1)) + 1
    dic2(a(i, 2)) = dic2(a(i, 2)) + 1
    dic3(a(i, 3)) = dic3(a(i, 3)) + 1
  Next
  
  With Worksheets("HELPER1")
    .Range("A1").Resize(dic1.Count).Value = Application.Transpose(dic1.keys)
    .Range("B1").Resize(dic1.Count).Value = Application.Transpose(dic1.items)
    .Range("C1").Resize(dic2.Count).Value = Application.Transpose(dic2.keys)
    .Range("D1").Resize(dic2.Count).Value = Application.Transpose(dic2.items)
    .Range("E1").Resize(dic3.Count).Value = Application.Transpose(dic3.keys)
    .Range("F1").Resize(dic3.Count).Value = Application.Transpose(dic3.items)
  End With
End Sub

 

[kbishop94]

Try this

Sub count_unique()
  Dim a As Variant, b As Variant, c As Variant, i As Long
  Dim dic1 As Object, dic2 As Object, dic3 As Object
 
  a = Sheets("HELPER").Range("C1:E" & Sheets("HELPER").Range("C" & Rows.Count).End(xlUp).Row).Value2
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set dic3 = CreateObject("Scripting.Dictionary")
  dic1.CompareMode = vbTextCompare
  dic2.CompareMode = vbTextCompare
  dic3.CompareMode = vbTextCompare
 
  For i = 1 To UBound(a)
    dic1(a(i, 1)) = dic1(a(i, 1)) + 1
    dic2(a(i, 2)) = dic2(a(i, 2)) + 1
    dic3(a(i, 3)) = dic3(a(i, 3)) + 1
  Next
 
  With Worksheets("HELPER1")
    .Range("A1").Resize(dic1.Count).Value = Application.Transpose(dic1.keys)
    .Range("B1").Resize(dic1.Count).Value = Application.Transpose(dic1.items)
    .Range("C1").Resize(dic2.Count).Value = Application.Transpose(dic2.keys)
    .Range("D1").Resize(dic2.Count).Value = Application.Transpose(dic2.items)
    .Range("E1").Resize(dic3.Count).Value = Application.Transpose(dic3.keys)
    .Range("F1").Resize(dic3.Count).Value = Application.Transpose(dic3.items)
  End With
End Sub

That is exactly what I was after.

Thank you, DanteAmor!!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[Fluff]

Another option

Sub kbishop()
   Dim Dic(1 To 3) As Object
   Dim i As Long, j As Long
   Dim ary As Variant
   
   For i = 1 To 3
      Set Dic(i) = CreateObject("scripting.dictionary")
      Dic(i).CompareMode = 1
   Next i
   With Sheets("Helper")
   Debug.Print .Range("C1:E" & .Range("C" & Rows.Count).End(xlUp).Row).Address
      ary = .Range("C1:E" & .Range("C" & Rows.Count).End(xlUp).Row).Value
   End With
   For i = 1 To UBound(ary)
      For j = 1 To 3
         Dic(j)(ary(i, j)) = Dic(j)(ary(i, j)) + 1
      Next j
   Next i
   With Sheets("Helper1")
   For i = 1 To 3
      .Cells(1, i * 2 - 1).Resize(Dic(i).Count, 2).Value = Application.Transpose(Array(Dic(i).Keys, Dic(i).Items))
   Next i
   End With
End Sub

 

[kbishop94]

Another option

Thank you, Fluff! (it was your code from a couple years back that I posted in my original post. It gets put to good use every day ?)

 

[kbishop94]

I also failed to mention that I also need the second column on the HELPER1 page (the numerical tally column) to be sorted starting with the highest value down to the lowest.

 

[DanteAmor]

to be sorted starting with the highest value down to the lowest.

Try this:

Sub count_unique()
  Dim a As Variant, b As Variant, c As Variant, i As Long
  Dim dic1 As Object, dic2 As Object, dic3 As Object
  
  a = Sheets("HELPER").Range("C1:E" & Sheets("HELPER").Range("C" & Rows.Count).End(xlUp).Row).Value2
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set dic3 = CreateObject("Scripting.Dictionary")
  dic1.CompareMode = vbTextCompare
  dic2.CompareMode = vbTextCompare
  dic3.CompareMode = vbTextCompare
  
  For i = 1 To UBound(a)
    dic1(a(i, 1)) = dic1(a(i, 1)) + 1
    dic2(a(i, 2)) = dic2(a(i, 2)) + 1
    dic3(a(i, 3)) = dic3(a(i, 3)) + 1
  Next
  
  With Worksheets("HELPER1")
    .Range("A1").Resize(dic1.Count).Value = Application.Transpose(dic1.Keys)
    .Range("B1").Resize(dic1.Count).Value = Application.Transpose(dic1.Items)
    .Range("C1").Resize(dic2.Count).Value = Application.Transpose(dic2.Keys)
    .Range("D1").Resize(dic2.Count).Value = Application.Transpose(dic2.Items)
    .Range("E1").Resize(dic3.Count).Value = Application.Transpose(dic3.Keys)
    .Range("F1").Resize(dic3.Count).Value = Application.Transpose(dic3.Items)
    .Range("A1:B" & .Range("A" & Rows.Count).End(xlUp).Row).Sort key1:=.Range("B1"), order1:=xlDescending, Header:=xlNo
    .Range("C1:D" & .Range("C" & Rows.Count).End(xlUp).Row).Sort key1:=.Range("D1"), order1:=xlDescending, Header:=xlNo
    .Range("E1:F" & .Range("E" & Rows.Count).End(xlUp).Row).Sort key1:=.Range("F1"), order1:=xlDescending, Header:=xlNo
  End With
End Sub

 

[Fluff]

Or, with mine

Sub kbishop()
   Dim Dic(1 To 3) As Object
   Dim i As Long, j As Long
   Dim ary As Variant
   
   For i = 1 To 3
      Set Dic(i) = CreateObject("scripting.dictionary")
      Dic(i).CompareMode = 1
   Next i
   With Sheets("Helper")
   Debug.Print .Range("C1:E" & .Range("C" & Rows.Count).End(xlUp).Row).Address
      ary = .Range("C1:E" & .Range("C" & Rows.Count).End(xlUp).Row).Value
   End With
   For i = 1 To UBound(ary)
      For j = 1 To 3
         Dic(j)(ary(i, j)) = Dic(j)(ary(i, j)) + 1
      Next j
   Next i
   With Sheets("Helper1")
      For i = 1 To 3
         With .Cells(1, i * 2 - 1).Resize(Dic(i).Count, 2)
            .Value = Application.Transpose(Array(Dic(i).Keys, Dic(i).Items))
            .Sort key1:=.Offset(, 1), Order1:=xlDescending, Header:=xlYes
         End With
      Next i
   End With
End Sub

 

[kbishop94]

Thank you both, so much.

This forum and its wealth of information from so many amazing experts has helped me out so much over the past several years.

I wish I could buy you all a beer (or 2)!