计数表上有700k行冻结程序

Question

我目前有两个列表。A列中的"授予人"列表和B列中删除重复项的同一列表。我正试图使用countif来计算给定授予人在A列中有多少次，但我在A列的列表超过了700k行。我使用的是64位excel，但每次运行代码时，excel都会冻结并崩溃。

有没有一种方法可以在excel中做到这一点，或者我需要采取另一种方法，比如使用透视表或在access中创建表？

我写了一些子程序，但这是最新的，来自这个论坛上的另一个帖子。

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

Answer 1

类似这样的东西：

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

运行时间约为30秒，A中为700k值，B 中为300k uniques

Answer 2

。。。或者这个。

_{注意：这会覆盖目标工作表A列中消除重复的值}

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

Surface Pro平板电脑上700K原件和327K uniques的42.64秒。这可以通过关闭计算和启用事件来改进。屏幕更新真的不应该是个问题。