问加速Excel中的匹配程序

EN

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

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

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