用于比较两个工作表并突出显示发生更改的宏

Question

我想在工作簿中创建一个可用作比较工具的宏。

历史数据将被添加到工作表1“历史”中。 然后，当前数据将添加到工作表2“新建”中。 数据格式完全相同。

宏应向下查看工作表1中的G列（这是键标识符），也向下看O列（显示状态）。 然后，应将此数据与工作表2中的G和O列进行比较。

如果G列是匹配项，但O列已更改，则应将工作表2“新建”中的整个行粘贴到工作表3“结果”中。

例;

工作表1“历史记录”-G列，123456789和O列，无效

工作表2“新建”-G列，123456789和O列，有效

由于G列中有匹配项，但状态已更改，因此工作表2中的行将粘贴到工作表3“结果”中的下一个空闲行中

任何帮助将不胜感激。 我一直在尝试将Vlookup和Countif添加到宏中，但没有成功。

Answer 1

这可能会给您一个想法，希望对您有所帮助。

Sub matchMe()
    Dim wS As Worksheet, wT As Worksheet
    Dim r1 As Range, r2 As Range
    Dim cel1 As Range, cel2 As Range

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

    With wS
        Set r1 = .Range("G1", .Cells(.Rows.Count, .Columns("G:G").Column).End(xlUp))
    End With

    With wT
        Set r2 = .Range("G1", .Cells(.Rows.Count, .Columns("G:G").Column).End(xlUp))
    End With

    On Error Resume Next
    For Each cel1 In r1
        With Application
            Set cel2 = .Index(r2, .Match(cel1.Value, r2, 0)) 'find match in sheet2
            If Err = 0 Then
                If cel1.Offset(, 8) <> cel2.Offset(, 8) Then copyRow cel2 'if difference, copy
            End If
            Err.Clear
        End With
    Next cel1
End Sub

Sub copyRow(cel As Range)
    Dim w As Worksheet, r As Range
    Set w = ThisWorkbook.Worksheets("Sheet3")
    Set r = w.Cells(w.Rows.Count, Columns("G:G").Column).End(xlUp).Offset(1) 'next row
    cel.EntireRow.Copy w.Cells(r.Row, 1)
End Sub