как сравнить строки из 2 листов, а затем скопировать разные строки на другой лист VBA

Question

у меня есть 2 листа:

Лист 1:

Лист 2:

Я провожу сравнение строк на листе 1 и листе 2 и исключаю первый столбец обоих. Я нашел следующий код в сети, но он возвращает, что нет строк, которые не соответствуют. однако на листе 2 есть дополнительная строка для c со значением 8,00 долл. США, которой нет на листе 1. это тот, который я хотел бы скопировать на лист 3.

когда я запускаю этот код, он говорит, что между листами нет различий, но в листе 2 определенно есть дополнительная строка, которая не найдено в листе 1, исключая первый столбец дат.

Может кто-нибудь помочь, пожалуйста?

Sub Compare()
    '
    ' Macro1 Macro
    '
    ' compare two different worksheets in the active workbook
    CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
End Sub

Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
    Dim dupRow As Boolean
    Dim r As Long, c As Integer, m As Integer
    Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer, lr3 As Long
    Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
    Dim dupCount As Long

    Application.ScreenUpdating = False
    Application.StatusBar = "Creating the report..."
    Application.DisplayAlerts = True
    With ws1.UsedRange
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With ws2.UsedRange
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    DiffCount = 0
    lr3 = 1
    For i = 1 To lr1
        dupRow = True
        Application.StatusBar = "Comparing worksheets " & Format(i / maxR, "0 %") & "..."
        For r = 1 To lr2
            For c = 2 To maxC
                ws1.Select
                cf1 = ""
                cf2 = ""
                On Error Resume Next
                cf1 = ws1.Cells(i, c).FormulaLocal
                cf2 = ws2.Cells(r, c).FormulaLocal
                On Error GoTo 0
                If cf1 <> cf2 Then
                    dupRow = False
                    Exit For
                Else
                    dupRow = True
                End If
            Next c
            If dupRow Then
                Exit For
            End If
        Next r
        If Not dupRow Then
            dupCount = dupCount + 1
            ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, maxC)).Select
            Selection.Copy
            Worksheets("Sheet3").Select
            Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(lr3, 1), Worksheets("Sheet3").Cells(lr3, maxC)).Select
            Selection.PasteSpecial
            lr3 = lr3 + 1
            ws1.Select
            For t = 1 To maxC
                ws1.Cells(i, t).Interior.ColorIndex = 19
                ws1.Cells(i, t).Select
                Selection.Font.Bold = True
            Next t
        End If
    Next i
    Application.StatusBar = "Formatting the report..."
    'Columns("A:IV").ColumnWidth = 10
    m = dupCount
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox m & " Rows contain different values!", vbInformation, _
           "Compare " & ws1.Name & " with " & ws2.Name


     End Sub

Answer 1

Ваш код только проверяет, дублированы ли какие-либо строки на Листе1, на Листе2. Вы не проверяете другой путь (Лист2 к Листу1). В вашем примере, если вы передадите Sheet2 в качестве первого параметра, вы получите правильный результат.

CompareWorksheets Worksheets("Sheet2"), Worksheets("Sheet1")

Но это может не сработать в другом наборе, где у вас есть несколько уникальных строк как в Sheet1, так и в Sheet2. , Для этого вы можете использовать свою логику c, но не забудьте сохранить номера строк на листе 2, которые дублируются. В конце также включите в Sheet3 строки, которые не были помечены как дубликаты.