Count occurrences using scripting dictionary

[horizonflame]

Hello

I have a spreadsheet with around 100k rows of data.

In Column A I have numerical values of which some will be occurring up to 100 times.

In Column B I need a count of how many times the value in the corresponding row has appeared in column A.

I have been using a column of countif formulas but very slow.

I’d prefer VBA solution to use in my wider code.

Any help would be appreciated

 

[saboh12617]

Hello,

Taking into account the huge amount of data, i propose you the code below which tries to minimize operations. It reads the whole list only two times. I tried it on a sample of 1000 rows and it was instant. I hope it works fine for you. Please adapt the sheets and references to correspond to your workbook before launching the macro.

Sub CountRepetitions()
  Application.ScreenUpdating = False

  ' reading list of values from excel
  Dim myVals
  With ThisWorkbook.Worksheets(1).Range("A1")
    myVals = Application.Transpose(Range(.Cells, .End(xlDown)).Value2)
  End With
 
  Dim repetitions As Object
  Set repetitions = CreateObject("Scripting.Dictionary")
 
  ' taking advantage of smart dictionary auto creating properties to countif
  Dim val
  For Each val In myVals
    repetitions(val) = repetitions(val) + 1
  Next val
 
  Dim countExport() As Long
  ReDim countExport(LBound(myVals) To UBound(myVals))
 
  ' creating an array of countifs
  Dim i As Long
  For i = LBound(myVals) To UBound(myVals)
    countExport(i) = CLng(repetitions(myVals(i)))
  Next i
 
  ' export to excel in one go
  ThisWorkbook.Worksheets(1).Range("B1").Resize(UBound(myVals), 1).Value2 = Application.Transpose(countExport)
 
End Sub

 

[Fluff]

How about

Sub horizonflame()
   Dim Ary As Variant
   Dim r As Long, Ub As Long
   
   With Range("A2", Range("A" & Rows.Count).End(xlUp))
      Ary = .Value2
   End With
   
   Ub = UBound(Ary)
   ReDim Preserve Ary(1 To Ub, 1 To 2)
   
   With CreateObject("scripting.dictionary")
      For r = 1 To Ub
         .Item(Ary(r, 1)) = .Item(Ary(r, 1)) + 1
      Next r
      For r = 1 To Ub
         Ary(r, 2) = .Item(Ary(r, 1))
      Next r
   End With
   Range("A2").Resize(Ub, 2).Value = Ary
End Sub

@saboh12617 as the OP has 100k rows of data, your code will probably fail because of the Transpose.

 

[saboh12617]

Thank you Fluff for the feedback. I was not aware of this limitation as I never worked with so big data. I used it to transform 2D arrays into 1D. With this in mind, your approach seems to fit perfectly, bravo.

 

[horizonflame]

Thank you both for your help.

Fluff, you code worked great.

 

[Fluff]

Glad we could help & thanks for the feedback.