在使用搜索时提高 excel vba 的性能

Question

我在两张表中有 400 000 条记录，每列 5 列，A 列中的数据是唯一标识符。两张表中的列顺序相同。我正在尝试搜索 Sheet1 中存在的记录并在 Sheet2 中找到它。如果找到，我需要将该记录的数据与 sheet2 中的数据进行比较。不匹配的数据应突出显示 sheet1 中的单元格并复制 sheet 3 中的整行。

我的宏对少量数据有效，但它被大数据挂起，excel 自动关闭。

我尝试评论单元格的突出显示并仅复制行并且仅分离 25000 条记录，但可能会看到与前面所述相同的性能问题。

Sub CompareSheets()

    Dim wS As Worksheet, wT As Worksheet, RS As Worksheet
    Dim intSheet1Column As Integer, i As Long, j As Long, k As Long, FoundRow As Long

    Set wS = ThisWorkbook.Worksheets("Sheet1")
    Set wT = ThisWorkbook.Worksheets("Sheet2")
    Set RS = ThisWorkbook.Worksheets("Sheet3")

    RS.Cells.ClearContents
    RS.Cells.Interior.Color = RGB(255, 255, 255)
    wS.Rows(1).EntireRow.Copy RS.Range("A1")

    On Error Resume Next
    For i = 2 To wS.UsedRange.Rows.Count
       For j = 2 To wT.UsedRange.Rows.Count
       If InStr(1, wT.Range("A" & j).Value, wS.Range("A" & i).Value) > 0 Then
                Match = "FOUND"
                FoundRow = j
       Exit For
       End If
       Next


       If Match = "FOUND" Then
           CopyFlag = False
            For intSheet1Column = 2 To wS.UsedRange.Columns.Count
               If wS.Cells(i, intSheet1Column).Value <> wT.Cells(FoundRow, intSheet1Column).Value Then
                  wS.Cells(i, intSheet1Column).Interior.Color = RGB(255, 255, 0)
                  CopyFlag = True
                  k = RS.UsedRange.Rows.Count
               End If
            Next
                  If CopyFlag = True Then
                        wS.Rows(i).EntireRow.Copy RS.Range("A" & k + 1)
                  End If
       End If
    Next

    MsgBox "Validation Complete"
End Sub

Excel 被挂起并自动关闭。

Answer 1

使用FIND试试这个代码：

Public Sub Test()

    Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet
    Dim sht1_LastCell As Range
    Dim sht1_Index As Range, rValue As Range
    Dim rFound As Range
    Dim bMismatch As Boolean
    Dim lRowToCopy As Long

    With ThisWorkbook
        Set sht1 = .Worksheets("Sheet1")
        Set sht2 = .Worksheets("Sheet2")
        Set sht3 = .Worksheets("Sheet3")
    End With

    'Return a reference to the last cell on Sheet1.
    Set sht1_LastCell = LastCell(sht1)

    With sht1
        'Look at each cell in Sheet1 Column A
        For Each sht1_Index In .Range(.Cells(1, 1), .Cells(sht1_LastCell.Row, 1))

            'Ensure the mismatch flag is set to FALSE.
            bMismatch = False

            'Find a match in Sheet2 Column A
            Set rFound = sht2.Columns(1).Find( _
                What:=sht1_Index, _
                After:=sht2.Columns(1).Cells(1), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlNext)

            'If value is found then compare.
            If Not rFound Is Nothing Then
                'Check each column, excluding column A:
                'OFFSET by 1 column to column B.
                'RESIZE single cell range to all cells from B to last column.
                For Each rValue In sht1_Index.Offset(, 1).Resize(, sht1_LastCell.Column - 1)

                    'To reference the correct cell on Sheet2 use the row number that was found
                    'and the column number from the value being looked at.
                    If rValue <> sht2.Cells(rFound.Row, rValue.Column) Then
                        rValue.Interior.Color = RGB(255, 255, 0)
                        lRowToCopy = rValue.Row
                        bMismatch = True
                    End If
                Next rValue
            End If

            'Copy the data from Sheet1 to the last row (+1 so it doesn't overwrite the last row) on Sheet3.
            If bMismatch Then
                sht1.Rows(lRowToCopy).Copy Destination:=sht3.Cells(LastCell(sht3).Row + 1, 1)
            End If

        Next sht1_Index
    End With

End Sub

'UsedRange can return an incorrect reference in certain circumstances.
'This function will always return a reference to the last cell containing data.
Public Function LastCell(wrkSht As Worksheet) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next
        With wrkSht
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        End With

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)

    On Error GoTo 0

End Function

Answer 2

我在查看您的代码时注意到以下几点： 这里：

            For intSheet1Column = 2 To wS.UsedRange.Columns.Count
               If wS.Cells(i, intSheet1Column).Value <> wT.Cells(FoundRow, intSheet1Column).Value Then
                  wS.Cells(i, intSheet1Column).Interior.Color = RGB(255, 255, 0)
                  CopyFlag = True
                  k = RS.UsedRange.Rows.Count
                  Exit For '<------ added
               End If
            Next

在第一次输入 if 语句后，你最好添加一个出口，因为 CopyFlag 不会变得更真实。

下一个可能更重要的事情是，您不要在第二个 if 语句中重置 Match，这意味着，在找到第一个匹配项后，它将进入 If 语句 If Match="Found" Then 用于每个后续 @987654323 @。这是故意的吗？如果没有，您可以添加如下内容：

       If Match = "FOUND" Then
           CopyFlag = False
            For intSheet1Column = 2 To wS.UsedRange.Columns.Count
               If wS.Cells(i, intSheet1Column).Value <> wT.Cells(FoundRow, intSheet1Column).Value Then
                  wS.Cells(i, intSheet1Column).Interior.Color = RGB(255, 255, 0)
                  CopyFlag = True
                  k = RS.UsedRange.Rows.Count
               End If
            Next
                  If CopyFlag = True Then
                        wS.Rows(i).EntireRow.Copy RS.Range("A" & k + 1)
                  End If
            Match="" '<------ added
       End If

Answer 3

我使用数组和函数来搜索第二张表中的 id。如果对 ID 列进行排序，我们可以做得更好。

Sub CompareSheets()

Dim sh1         As Worksheet
Dim sh2         As Worksheet
Dim sh3         As Worksheet
Dim arr1        As Variant
Dim arr2        As Variant
Dim Row1        As Long
Dim Row2        As Long
Dim Row3        As Integer
Dim o           As Long
Dim nOfColumns  As Integer
Dim myId        As String

Set sh1 = ThisWorkbook.Worksheets("Sheet1")
Set sh2 = ThisWorkbook.Worksheets("Sheet2")
Set sh3 = ThisWorkbook.Worksheets("Sheet3")

nOfColumns = 5
Row3 = 2

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Here I start from second row assuming there's columns header
With sh1
    arr1 = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.count, "A").End(xlUp).row, nOfColumns)).Value
End With

With sh2
    arr2 = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.count, "A").End(xlUp).row, nOfColumns)).Value
End With

For Row1 = LBound(arr1, 1) To UBound(arr1, 1)

    myId = arr1(Row1, 1) ' I assume that ID is in column 1
    Row2 = FindRow(arr2, myId)

    If Row2 < 0 Then
        ' Format the sh1 row not founded
        With sh1
            .Range(.Cells(Row1 + 1, 1), .Cells(Row1 + 1, UBound(arr1, 2))).Interior.Color = vbGreen
        End With
        ' Put the row not founded in sh3
        With sh3
            For o = LBound(arr1, 2) To UBound(arr1, 2)
                .Cells(Row3, o).Value = arr1(Row1, o)
            Next o
            Row3 = Row3 + 1
        End With
    End If

Next Row1

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

Erase arr1
Erase arr2
Set sh1 = Nothing
Set sh2 = Nothing
Set sh3 = Nothing

End Sub

Function FindRow(ByRef myArray As Variant, _
            ValueToSearch As Variant, _
            Optional IndexToSearchIn As Long = 1) As Long

FindRow = -1
If Not IsArray(myArray) Then Exit Function

Dim lB          As Long
Dim uB          As Long
Dim Counter     As Long

lB = LBound(myArray, 1)
uB = UBound(myArray, 1)

For Counter = lB To uB
    If myArray(Counter, IndexToSearchIn) = ValueToSearch Then
        FindRow = Counter
        Exit Function
    End If
Next Counter

End Function