Excel VBA - 如何更有效地进行计数？答案

【问题标题】：Excel VBA - How to do countif more efficiently?Excel VBA - 如何更有效地进行计数？
【发布时间】：2017-06-25 23:46:50
【问题描述】：

我正在为电子表格编写 Excel VBA 代码。下面的代码的目的是计算这一行的凭证号在整个 G 列中出现的次数。由于原始数据有 60,000 多行，下面的代码需要 2 分钟以上才能完成。

Worksheets("Raw Data").Range("AP2:AP" & lastrow).Formula = "=IF(AO2=""MATCHED"",""MATCHED"",IF((COUNTIF(AQ_u,G2))>0,""MATCHED"",""NOT MATCHED""))"

我也尝试了一种alternatvie方式，基本上也是一个CountIF函数：

Dim cel, rng As Range
Set rng = Worksheets("Raw Data").Range("AQ2:AQ" & lastrow)
For Each cel In Worksheets("Raw Data").Range("AQ2:AQ" & lastrow)
     If Application.WorksheetFunction.CountIf(rng, cel.Offset(0, -36).Value) > 0 Then
        cel.Offset(0, -1).Value = 1
     End If
Next cel

上面的两个代码都需要很长时间才能完成，所以我想知道是否有办法让代码更高效？非常感谢。

【问题讨论】：

根据你想要达到的目标试试这个： =SUMPRODUCT(--($G$1:$G$60000=AP1)) 基本上计算列 G 中与 AP1 中的值匹配的所有值。希望对你有帮助
@Fredlo2010 谢谢。对不起，我没有说清楚。我需要计算每一行中的值，这意味着 AP1 需要是 2 到 60,000 之间的变量。我还能这样使用你的代码吗？
关闭屏幕更新和计算；因为您只需要确定是否有零个匹配项与一个或多个匹配项，请使用Range.Find 方法而不是CountIf。如果仍然很慢，请将范围读入 VBA 数组；然后实现一个二分查找算法。根据您的真实数据，您也许可以使用数据透视表。
@Ron Rosenfeld 我认为用户正在尝试数数。
@Fredlo2010 在 VBA 代码中，他写道：If Application.WorksheetFunction.CountIf(rng, cel.Offset(0, -36).Value) > 0 Then cel.Offset(0, -1).Value = 1 这对我来说似乎不算数，而是一个简单的测试。在他将公式写入工作表的原始代码中，他再次使用COUNTIF，但如果返回的值为>0，则仅写入一个结果

标签： vba performance excel

【解决方案1】：

试试下面的代码（它使用数组和字典）

对于字典的后期绑定很慢：~~CreateObject("Scripting.Dictionary")~~

早期绑定很快：VBA 编辑器 -> 工具 -> 参考 -> 添加 Microsoft 脚本运行时

Option Explicit

Public Sub CountVouchers()
    Const G     As Long = 7     'col G
    Const AQ    As Long = 43    'col AQ

    Dim ws  As Worksheet:   Dim i  As Long:     Dim d As Dictionary
    Dim arr As Variant:     Dim lr As Long:     Dim t As Double

    t = Timer:              Set d = New Dictionary

    Set ws = ThisWorkbook.Worksheets("Raw Data")
    lr = ws.Cells(ws.Rows.Count, AQ).End(xlUp).Row
    ws.Columns("AP").Clear

    arr = ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ))                'Range to Array
        For i = 2 To lr
            If Len(Trim(arr(i, AQ))) > 0 Then d(CStr(arr(i, AQ))) = 1
        Next
        For i = 2 To lr
            If d.Exists(CStr(arr(i, G))) Then arr(i, AQ - 1) = 1    'Count
        Next
    ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) = arr                'Array back to Range

Debug.Print "Rows: " & Format(lr, "#,###") & ", Time: " & Format(Timer - t, ".000") & " sec"

    'Rows: 100,001, Time: 1.773 sec

End Sub

如果您想查看每张优惠券的总出现次数：

Public Sub CountVoucherOccurrences()
    Const G     As Long = 7
    Const AQ    As Long = 43

    Dim ws  As Worksheet:   Dim i  As Long:     Dim d As Dictionary
    Dim arr As Variant:     Dim lr As Long:     Dim t As Double

    t = Timer:              Set d = New Dictionary

    Set ws = ThisWorkbook.Worksheets("Raw Data")
    lr = ws.Cells(ws.Rows.Count, AQ).End(xlUp).Row
    ws.Columns("AP").Clear

    arr = ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ))
        For i = 2 To lr
            d(arr(i, AQ)) = IIf(Not d.Exists(arr(i, AQ)), 1, d(arr(i, AQ)) + 1)
        Next
        For i = 2 To lr
           If d.Exists(arr(i, G)) Then arr(i, AQ - 1) = d(arr(i, AQ))
        Next
    ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) = arr

Debug.Print "Rows: " & Format(lr, "#,###") & ", Time: " & Format(Timer - t, ".000") & " sec"

    'Rows: 100,001, Time: 1.781 sec

End Sub

【讨论】：

谢谢保罗！这正是我需要的！我花了4秒才完成！这么快！