Улучшение производительности Excel VBA при использовании поиска

Question

У меня 400 000 записей на двух листах по 5 столбцов с данными в столбце А, являющимися уникальным идентификатором. Порядок столбцов на обоих листах одинаков. Я пытаюсь найти запись, которая существует в Sheet1, и найти ее в Sheet2. Если найдено, мне нужно сравнить данные этой записи с данными на листе 2. Несоответствующие данные должны выделять ячейки на листе 1 и копировать всю строку на листе 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 не собирается получать какие-либоболее истинныйкаждый последующий i. Это намеренно? Если нет, вы можете добавить что-то вроде:

       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