vba - Excel VBA 中的加速匹配程序

Question

我正在 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 多行代码，我想找到更快的解决方案。我认为必须有一种方法可以避免过度循环

条件如下:

For each line, if another line anywhere in the file has the exact same :

• Buyer ID (col. E)
• `# purchased (col. F)
• Product ID (col.A)
• Payment (col. J)
• Date purchased (col. H)

Then, if the SUM of the Amount (col. L) the those two matching line is 0, then color both rows in yellow.

Note that extra columns are present and not being compared (eg- col. B) but are still important for the document and cannot be deleted to ease the process.

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

Answer 1

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

带有我的测试数据的计时器:行:100,001；骗局:70,000 - 时间:14.217 秒

<小时/>

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

<小时/>

之前

之后