VBA for Unique Count

[Stephen_IV]

Good evening,

I am looking for VBA to do some unique counting for me. I have over 200000 rows of data. The formula approach I have been using is below. But I really want to automate to VBA.

{=SUM(IF(FREQUENCY(IF(($A$2:$A$22=F2),$B$2:$B$22),$B$2:$B$22)>=1,1))}

<style type="text/css">
table.tableizer-table {
font-size: 12px;
border: 1px solid #CCC ;
font-family: Arial, Helvetica, sans-serif;
}
.tableizer-table td {
padding: 4px;
margin: 3px;
border: 1px solid #CCC ;
}
.tableizer-table th {
background-color: #104E8B ;
color: #FFF ;
font-weight: bold;
}
</style>
<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>STUDENTID</th><th>SCHOOLID</th></tr></thead><tbody>
<tr><td>100</td><td>2207264</td></tr>
<tr><td>100</td><td>2207264</td></tr>
<tr><td>100</td><td>2207264</td></tr>
<tr><td>100</td><td>2207264</td></tr>
<tr><td>100</td><td>2207264</td></tr>
<tr><td>100</td><td>2207264</td></tr>
<tr><td>100</td><td>2207264</td></tr>
<tr><td>100</td><td>2207264</td></tr>
<tr><td>113</td><td>2207264</td></tr>
<tr><td>113</td><td>2207264</td></tr>
<tr><td>113</td><td>2216264</td></tr>
<tr><td>113</td><td>2216264</td></tr>
<tr><td>113</td><td>2209264</td></tr>
<tr><td>127</td><td>2216264</td></tr>
<tr><td>127</td><td>2216264</td></tr>
<tr><td>127</td><td>2216264</td></tr>
<tr><td>127</td><td>2209264</td></tr>
<tr><td>127</td><td>2216264</td></tr>
<tr><td>127</td><td>2216264</td></tr>
<tr><td>127</td><td>2216264</td></tr>
<tr><td>127</td><td>2216264</td></tr>
</tbody></table>

<style type="text/css">
table.tableizer-table {
font-size: 12px;
border: 1px solid #CCC ;
font-family: Arial, Helvetica, sans-serif;
}
.tableizer-table td {
padding: 4px;
margin: 3px;
border: 1px solid #CCC ;
}
.tableizer-table th {
background-color: #104E8B ;
color: #FFF ;
font-weight: bold;
}
</style>


<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>STUDENTID</th><th>SCHOOLID</th></tr></thead><tbody>
<tr><td>100</td><td>1</td></tr>
<tr><td>113</td><td>3</td></tr>
<tr><td>127</td><td>2</td></tr>
</tbody></table>

 

[Kenneth Hobson]

What is the value of F2?

 

[Stephen_IV]

F2: Houses the StudentID,
G2: houses the Count

<style type="text/css">
table.tableizer-table {
font-size: 12px;
border: 1px solid #CCC ;
font-family: Arial, Helvetica, sans-serif;
}
.tableizer-table td {
padding: 4px;
margin: 3px;
border: 1px solid #CCC ;
}
.tableizer-table th {
background-color: #104E8B ;
color: #FFF ;
font-weight: bold;
}
</style>
<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>STUDENTID</th><th>SCHOOLID</th></tr></thead><tbody>
<tr><td>100</td><td>1</td></tr>
<tr><td>113</td><td>3</td></tr>
<tr><td>127</td><td>2</td></tr>
</tbody></table>

 

[Kenneth Hobson]

Normally, I would use a helper column and Autofilter.

See if this works fast enough. You may want to add an output range clear.

Sub UniquesAndCounts()
  Dim rIn As Range, rOut As Range, a, b, i As Long
  Dim c1$, c2$, s$
  
  'CHANGE TO SUIT
  Set rOut = Worksheets("Sheet1").Range("F2")
  With Worksheets("Sheet1")
    Set rIn = .Range("A2", .Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
  End With
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  a = UniqueArrayByDict(rIn.Columns(1).Value)
  rOut.Resize(UBound(a) + 1) = WorksheetFunction.Transpose(a)
  
  s = rIn.Parent.Name
  c1 = s & "!" & rIn.Columns(1).Address
  c2 = s & "!" & rIn.Columns(2).Address
  b = a
  For i = 0 To UBound(a)
    s = "=SUM(IF(FREQUENCY(IF((" & c1 & "=" & a(i) & _
      ")," & c2 & ")," & c2 & ")>=1,1))"
    b(i) = Evaluate(s)
  Next i
  
  rOut.Offset(, 1).Resize(UBound(a) + 1) = WorksheetFunction.Transpose(b)
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
End Sub

'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function

 

[Domenic]

The following code also uses a dictionary, but avoids having to evaluate an array formula. Note, however, it may not necessarily be more efficient.

Option Explicit

Sub UniquesAndCounts()


    Dim dicStudents As Object
    Dim dicItem As Variant
    Dim rngSource As Range
    Dim studentID As String
    Dim schoolID As String
    Dim schoolCount As Long
    Dim nextRow As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    Set dicStudents = CreateObject("Scripting.Dictionary")
    
    Set rngSource = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
    
    For i = 2 To rngSource.Rows.Count
        studentID = Cells(i, "A").Value
        schoolID = Cells(i, "B").Value
        If Not dicStudents.Exists(studentID) Then
            dicStudents.Add studentID, schoolID
        Else
            If InStr(1, "|" & dicStudents(studentID) & "|", "|" & schoolID & "|") = 0 Then
                dicStudents(studentID) = dicStudents(studentID) & "|" & schoolID
            End If
        End If
    Next i
    
    nextRow = 2
    For i = 0 To dicStudents.Count - 1
        studentID = dicStudents.keys()(i)
        schoolID = dicStudents.items()(i)
        Cells(nextRow, "F").Value = studentID
        Cells(nextRow, "G").Value = Len(schoolID) - Len(Replace(schoolID, "|", "")) + 1
        nextRow = nextRow + 1
    Next i
    
    Application.ScreenUpdating = True
        
End Sub

Hope this helps!

 

[Fluff]

Another variation

Sub Stephen_IV()
   Dim Ary As Variant, Ky As Variant
   Dim Dic As Object
   Dim i As Long
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Report")
      Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp).Offset(, 2)).Value2
   End With
   For i = 1 To UBound(Ary)
      If Not Dic.Exists(Ary(i, 1)) Then Dic.Add Ary(i, 1), CreateObject("scripting.dictionary")
      Dic(Ary(i, 1))(Ary(i, 2)) = Empty
   Next i
   For Each Ky In Dic.Keys
      With Sheets("Report").Range("F" & Rows.Count).End(xlUp).Offset(1)
         .Value = Ky
         .Offset(, 1).Value = Dic(Ky).Count
      End With
   Next Ky
End Sub

 

[Stephen_IV]

Thank you all for replying to my thread!!! Fluff seems like yours works very well. To all I learned a lot, thank you very much!!

 

[Fluff]

You're welcome & thanks for the feedback