Question

我正在处理电子表格的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""))"

我还尝试了一种替代方法，它基本上也是一个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

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

Answer 1

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

对于字典，后期绑定很慢： ~~CreateObject（“Scripting.Dictionary”）~~

早期绑定很快：VBA编辑器 - ＆gt;工具 - ＆gt;参考文献 - ＆gt;添加Microsoft Scripting Runtime

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

Excel VBA - 如何更有效地做countif？

1 个答案: