I currently have two lists. A list of “Grantors” in column A and the same list with duplicates removed in column B. I am trying to get a count of how many times a given Grantor is in Column A using countif however my list in Column A is over 700k rows. I am using 64bit excel but every time I run code to do this excel freezes and crashes.
Is there a way to do this in excel or do I need to take another approach like using a pivot table or creating tables in access?
I have written a few sub routines but this is the latest, got from another post on this forum.
Sub Countif() Dim lastrow As Long Dim rRange As Range Dim B As Long '< dummy variable to represent column B B = 2 With Application .ScreenUpdating = False 'speed up processing by turning off screen updating .DisplayAlerts = False End With 'set up a range to have formulas applied With Sheets(2) lastrow = Cells(Rows.Count, "A").End(xlUp).Row Set rRange = .Range(.Cells(2, B), .Cells(lastrow, B)) End With 'apply the formula to the range rRange.Formula = "=COUNTIF($A$2:$A$777363,C2)" 'write back just the value to the range rRange.Value = rRange.Value With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub
Something like this:
Sub Countif() Dim allVals, uniqueVals, i As Long, dict, v, dOut(), r As Long ''creating dummy data ' With Sheet2.Range("A2:A700000") ' .Formula = "=""VAL_"" & round(RAND()*340000,0)" ' .Value = .Value ' End With ' 'get the raw data and unique values With Sheet2 allVals = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value uniqueVals = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value End With ReDim dOut(1 To UBound(uniqueVals, 1), 1 To 1) 'for counts... Set dict = CreateObject("scripting.dictionary") 'map unique value to index For i = 1 To UBound(uniqueVals, 1) v = uniqueVals(i, 1) If Len(v) > 0 Then dict(v) = i Next i 'loop over the main list and count each unique value in colB For i = 1 To UBound(allVals, 1) v = allVals(i, 1) If Len(v) > 0 Then If dict.exists(v) Then r = dict(v) dOut(r, 1) = dOut(r, 1) + 1 End If End If Next i 'output the counts Sheet2.Range("C2").Resize(UBound(dOut, 1), 1).Value = dOut End Sub
Runs in ~30sec with 700k values in A and 300k uniques in B
… or maybe this.
Caution: this overwrites the de-duplicated values in column A of the target worksheet.
Option Explicit Sub countUnique() Dim arr As Variant, i As Long, dict As Object Debug.Print Timer Set dict = CreateObject("scripting.dictionary") dict.comparemode = vbTextCompare With Worksheets("sheet2") arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2 End With For i = LBound(arr, 1) To UBound(arr, 1) dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + 1 Next i With Worksheets("sheet3") .Cells(2, "A").Resize(dict.Count, 1) = bigTranspose(dict.keys) .Cells(2, "B").Resize(dict.Count, 1) = bigTranspose(dict.items) End With Debug.Print Timer End Sub Function bigTranspose(arr1 As Variant) Dim t As Long ReDim arr2(LBound(arr1) To UBound(arr1), 1 To 1) For t = LBound(arr1) To UBound(arr1) arr2(t, 1) = arr1(t) Next t bigTranspose = arr2 End Function
42.64 seconds for 700K originals and 327K uniques on a Surface Pro tablet. This might be improved by turning off calculation and enableevents. Screenupdating really shouldn’t be an issue.