加快 Excel VBA 中的匹配程序答案

【问题标题】：Speed Up Matching program in Excel VBA加快 Excel VBA 中的匹配程序
【发布时间】：2018-06-13 06:31:20
【问题描述】：

我正在使用循环在 excel 上编写 VBA 代码以通过 10000+ 行。

这是一个表格的例子

这是我写的代码：

Sub Find_Matches()

    Dim wb As Workbook
    Dim xrow As Long

    Set wb = ActiveWorkbook
    wb.Worksheets("Data").Activate

    tCnt = Sheets("Data").UsedRange.Rows.Count
    Dim e, f, a, j, h As Range
    xrow = 2

    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    For xrow = 2 To tCnt Step 1
        Set e = Range("E" & xrow)
        Set f = e.Offset(0, 1)
        Set a = e.Offset(0, -4)
        Set j = e.Offset(0, 5)
        Set h = e.Offset(0, 3)
        For Each Cell In Range("E2:E" & tCnt)
            If Cell.Value = e.Value Then
                If Cell.Offset(0, 1).Value = f.Value Then
                    If Cell.Offset(0, -4).Value = a.Value Then
                        If Cell.Offset(0, 5).Value = j.Value Then
                            If Cell.Offset(0, 3).Value = h.Value Then
                                If (e.Offset(0, 7).Value) + (Cell.Offset(0, 7).Value) = 0 Then
                                    Cell.EntireRow.Interior.Color = vbYellow
                                    e.EntireRow.Interior.Color = vbYellow
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        Next
    Next
End Sub

您可以想象，这需要花费大量时间来处理 10000 多行，我想找到一个更快的解决方案。必须有一种我认为不会避免过度循环

的方法

条件如下：

对于每一行，如果文件中任何位置的另一行具有完全相同的：

买家 ID（E 栏）

`# 已购买（F 列）

产品 ID (col.A)

付款（J 栏）

购买日期（H 栏）

那么，如果金额的总和（col. L）那两个匹配的行是 0，然后将两行都涂成黄色。

请注意，存在额外的列并且未进行比较（例如，B 列），但对文档仍然很重要，不能删除以简化流程。

运行前面的代码，在我的示例中，第 2 行和第 5 行被突出显示：

【问题讨论】：

如果您的代码已经可以工作，这可能是Stack Exchange: Code Review 的一个更好的问题。
请注意，当您对变量进行调暗时，只有 h 是一个范围。所有其他（e，f，a，j）都是变体。你需要在每一个之后写上“As Range”。关于速度 - 您是否尝试在循环遍历数组之前将所有单元格复制到二维数组中？使用数组比不断地与工作表交互要快。
不，我没有。这正是我正在寻找的那种输入：“我没有想到什么？”谢谢！
谢谢@Pᴇʜ 我不会说代码本身可以工作，因为它太慢而无法使用。它只满足规定的条件。如果您认为它仍然可以工作并且应该去 Stack Exchange，我会很乐意将帖子转移到那里！
哇。该死的，这是一个很大的SORRY！你是对的。=)

标签： vba excel performance

【解决方案1】：

这是使用嵌套字典和数组来检查所有条件

带有我的测试数据的计时器：Rows: 100,001; Dupes: 70,000 - Time: 14.217 sec

Option Explicit

Public Sub FindMatches()
    Const E = 5, F = 6, A = 1, J = 10, H = 8, L = 12

    Dim ur As Range, x As Variant, ub As Long, d As Object, found As Object

    Set ur = ThisWorkbook.Worksheets("Data").UsedRange
    x = ur
    Set d = CreateObject("Scripting.Dictionary")
    Set found = CreateObject("Scripting.Dictionary")

    Dim r As Long, rId As String, itm As Variant, dupeRows As Object

    For r = ur.Row To ur.Rows.Count
        rId = x(r, E) & x(r, F) & x(r, A) & x(r, J) & x(r, H)
        If Not d.Exists(rId) Then
            Set dupeRows = CreateObject("Scripting.Dictionary")
            dupeRows(r) = 0
            Set d(rId) = dupeRows
        Else
            For Each itm In d(rId)
                If x(r, L) + x(itm, L) = 0 Then
                    found(r) = 0
                    found(itm) = 0
                End If
            Next
        End If
    Next
    Application.ScreenUpdating = False
    For Each itm In found
        ur.Range("A" & itm).EntireRow.Interior.Color = vbYellow
    Next
    Application.ScreenUpdating = True
End Sub

之前

之后

【讨论】：

好的，谢谢！这是一个非常酷的解决方案和方法。我的方法太直截了当（如果那么如果那么如果那么...）而且这个方法很棒。效果很好！
优雅的解决方案！

【解决方案2】：

我建议完全不同的方法：向您的数据添加一个临时列，其中包含行中每个单元格的串联。这样，您就有：

A|B|C|D|E
1|Mr. Smith|500|A|1Mr. Smith500A

然后在临时列上使用 Excel 的条件格式，突出显示重复值。那里有重复的行。现在只需使用过滤器来检查哪些数量为零。

你可以使用CONCATENATE函数；它要求您分别指定每个单元格，并且您不能使用范围，但在您的情况下（仅比较某些列），它似乎很合适。

【讨论】：

嗯...我明白你在这里做了什么，这是一个非常好的主意。但是，在我的原始文件中，没有一个项目与第一个条件不匹配（帖子中的要点列表）。所以一切都可能有重复。我需要强调的是相互抵消的线条（line1+line2=0）。或者我误解了:)
我不太明白你的意思是什么标准。如果所有行都符合其中一个条件，为什么不删除它？

【解决方案3】：

Maciej 的答案很容易实现（如果您可以在不中断任何内容的情况下向数据添加列），如果可能的话，我会推荐它。

但是，为了回答您的问题，我也会提供一个 VBA 解决方案。我在比你的数据集小一点的数据集上对其进行了测试，但我认为它对你有用。请注意，您可能需要稍微调整一下（从哪一行开始、表名等）以适合您的工作簿。

最值得注意的是，带有“帮助列”注释的段是您最有可能需要调整的部分 - 目前，它比较当前行的 A 和 H 之间的每个单元格，这可能是您想要的，也可能不想要。

我尝试在代码中包含一些注释，但并不多。主要变化是我使用了数组的内存处理，而不是遍历工作表范围（对于更大的数据集，这应该是指数级的更快）。

Option Base 1
Option Explicit
' Uses ref Microsoft Scripting Runtime

Sub Find_Matches()
    Dim wb As Workbook, ws As Worksheet
    Dim xrow As Long, tCnt As Long
    Dim e As Range, f As Range, a As Range, j As Range, h As Range
    Dim sheetArr() As Variant, arr() As Variant
    Dim colorTheseYellow As New Dictionary, colorResults() As String, dictItem As Variant
    Dim arrSize As Long, i As Long, k As Long
    Dim c As Variant

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Data")
    ws.Activate

    tCnt = ws.UsedRange.Rows.Count
    xrow = 2

    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    ' Read range into an array so we process in-memory
    sheetArr = ws.Range("A2:H" & tCnt)
    arrSize = UBound(sheetArr, 1)

    ' Build new arr with "helper column"
    ReDim arr(1 To arrSize, 1 To 9)
    For i = 1 To arrSize
        For k = 1 To 8
            arr(i, k) = sheetArr(i, k)
            arr(i, 9) = CStr(arr(i, 9)) & CStr(arr(i, k)) ' "Helper column"
        Next k
    Next i

    ' Iterate over array & build collection to indicate yellow lines
    For i = LBound(arr, 1) To UBound(arr, 1)
        If Not colorTheseYellow.Exists(i) Then colorResults = Split(ReturnLines(arr(i, 9), arr), ";")
        For Each c In colorResults
            If Not colorTheseYellow.Exists(CLng(c)) Then colorTheseYellow.Add CLng(c), CLng(c)
        Next c
    Next i

    ' Enact row colors
    For Each dictItem In colorTheseYellow
        'Debug.Print "dict: "; dictItem
        If dictItem <> 0 Then ws.ListObjects(1).ListRows(CLng(dictItem)).Range.Interior.Color = vbYellow
    Next dictItem
End Sub


Function ReturnLines(ByVal s As String, ByRef arr() As Variant) As String
    ' Returns a "Index;Index" string indicating the index/indices where the second, third, etc. instance(s) of s was found
    ' Returns "0;0" if 1 or fewer matches

    Dim i As Long
    Dim j As Long
    Dim tmp As String
    ReturnLines = 0
    j = 0
    tmp = "0"

    'Debug.Print "arg: " & s

    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, 9) = s Then
            j = j + 1
            'Debug.Print "arr: " & arr(i, 9)
            'Debug.Print "ReturnLine: " & i
            tmp = tmp & ";" & CStr(i)
        End If
    Next i

    'If Left(tmp, 1) = ";" Then tmp = Mid(tmp, 2, Len(tmp) - 1)

    'Debug.Print "tmp: " & tmp
    If j >= 2 Then
        ReturnLines = tmp
    Else
        ReturnLines = "0;0"
    End If
End Function

在我的简单数据集上，它产生了这个结果（用手绘颜色指示器标记得很好）：

【讨论】：

谢谢！我看到你在那里做了什么，它应该可以运行，但由于某种原因我可以让宏运行。
就像我在答案中提到的那样，您很可能需要对其进行一些调整。需要调整的部分取决于您遇到的错误（或不应该发生的错误）。
是的，你是对的。而且我想我找到了我之前忘记编辑的那行，再次感谢我也设法使它与这个解决方案一起工作！

【解决方案4】：

谢谢大家的回答，

Paul Bica 的解决方案确实有效，我现在正在使用此代码的一个版本。

但是，为了让辩论更加生动，我想我还找到了绕过我的第一个代码的另一种方法，灵感来自 Maciej 连接单元格并使用 CStr 比较值，当然还有Vegard 的内存处理，使用数组而不是通过工作簿：

Sub Find_MatchesStr()

    Dim AmountArr(300) As Variant
    Dim rowArr(300) As Variant
    Dim ws As Worksheet
    Dim wb As Workbook
    Set ws = ThisWorkbook.Sheets("Data")
    ws.Activate
    Range("A1").Select

    rCnt = ws.Cells.SpecialCells(xlCellTypeLastCell).Row

    For i = 2 To rCnt
        If i = rCnt Then
            Exit For
        Else
        intCnt = 0
        strA = ws.Cells(i, 1).Value
        strE = ws.Cells(i, 5).Value
        strF = ws.Cells(i, 6).Value
        strH = ws.Cells(i, 8).Value
        strL = ws.Cells(i, 10).Value

        For j = i To rCnt - 1
            strSearchA = ws.Cells(j, 1).Value
            strSearchE = ws.Cells(j, 5).Value
            strSearchF = ws.Cells(j, 6).Value
            strSearchH = ws.Cells(j, 8).Value
            strSearchL = ws.Cells(j, 10).Value

            If CStr(strE) = CStr(strSearchE) And CStr(strA) = CStr(strSearchA) And CStr(strF) = CStr(strSearchF) And CStr(strH) = CStr(strSearchH) And CStr(strL) = CStr(strSearchL) Then

                AmountArr(k) = ws.Cells(j, 12).Value
                rowArr(k) = j
                intCnt = intCnt + 1
                k = k + 1
            Else
                Exit For
            End If
        Next
        strSum = 0
        For s = 0 To UBound(AmountArr)
            If AmountArr(s) <> "" Then
                strSum = strSum + AmountArr(s)
            Else
                Exit For
            End If
        Next
        strAppenRow = ""
        For b = 0 To UBound(rowArr)
            If rowArr(b) <> "" Then
                strAppenRow = strAppenRow & "" & rowArr(b) & "," & AmountArr(b) & ","
            Else
                Exit For
            End If
        Next

        If intCnt = 1 Then

        Else
            If strSum = 0 Then
                For rn = 0 To UBound(rowArr)
                    If rowArr(rn) <> "" Then
                        Let rRange = rowArr(rn) & ":" & rowArr(rn)
                        Rows(rRange).Select
                        Selection.Interior.Color = vbYellow
                    Else
                        Exit For
                    End If
                Next
            Else
                strvar = ""
                strvar = Split(strAppenRow, ",")
                For ik = 1 To UBound(strvar)
                    If strvar(ik) <> "" Then
                        strVal = CDbl(strvar(ik))
                        For ik1 = ik To UBound(strvar)
                            If strvar(ik1) <> "" Then
                                strVal1 = CDbl(strvar(ik1))
                                If strVal1 + strVal = 0 Then
                                    Let sRange1 = strvar(ik - 1) & ":" & strvar(ik - 1)
                                    Rows(sRange1).Select
                                    Selection.Interior.Color = vbYellow
                                    Let sRange = strvar(ik1 - 1) & ":" & strvar(ik1 - 1)
                                    Rows(sRange).Select
                                    Selection.Interior.Color = vbYellow
                                End If
                            Else
                                Exit For
                            End If
                            ik1 = ik1 + 1
                        Next
                    Else
                        Exit For
                    End If
                    ik = ik + 1
                Next
            End If
        End If
        i = i + (intCnt - 1)
        k = 0
        Erase AmountArr
        Erase rowArr
        End If
    Next
    Range("A1").Select

End Sub

我仍然有一些错误（应该突出显示的行没有突出显示），上面的代码并不完美，但我认为在 Paul Bica 的解决方案出现之前让您了解我的去向是可以的。

再次感谢！

【讨论】：

【解决方案5】：

如果您的数据只到 L 列，那么使用下面的代码，我发现运行时间更短......

Sub Duplicates()
    Application.ScreenUpdating = False
    Dim i As Long, lrow As Long
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("O2") = "=A2&E2&F2&J2&L2"
    Range("P2") = "=COUNTIF(O:O,O2)"
    Range("O2:P" & lrow).FillDown
    Range("O2:O" & lrow).Copy
    Range("O2:O" & lrow).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    For i = 1 To lrow
        If Cells(i, 16) = 2 Then
            Cells(i, 16).EntireRow.Interior.Color = vbYellow
        End If
    Next
    Application.ScreenUpdating = True
    Range("O:P").Delete
    Range("A1").Select
    MsgBox "Done"
End Sub

【讨论】：

你应该很好地格式化你的代码，这是一团糟。查看help center 了解操作方法。
您还应该避免复制和粘贴操作，因为它们很容易在 VBA 中产生错误