EXCEL VBA:比较然后更新/更改，删除并在2张纸之间添加

Question

我正在比较同一工作簿中的 2 个工作表，逐行(以及该行的每个单元格(此代码能够识别哪一行已更改(CHANGE(，如果第二张表中不存在，则将其显示为已删除(删除(，或者如果这仅存在于第二张工作表中，则需要添加(ADD(。因此，工作表中的选项卡是：

原始 \ 更新 \ 更改

我试图实现的是创建应用所有更改的第四个(FINAL(，但在我到达那里之前，我发现代码存在一些问题(BTW 源代码和模板位于：这里(它工作得很好(使用 REMOVE 和 ADD(，但是当使用大量注册表(数百个(其中一些时， 标记为更改不会显示正确的值，有时，在相同的选项卡中返工并尝试再次应用宏会在标记的行 (*( 处出错。

即：原始 \ 更新 \ 已更改

Car_01 |500| 毫秒 \ Car_01 |750 |毫秒 \ Car_01| 15.5| 毫秒

起初，我

解决了这个问题，认为这与单元格中的参数类型与它必须在宏中的输入有关，但到目前为止，我还没有找到正确的类型(已经尝试过：常规、数字和文本(。因此，有关如何显示第四张工作表和值类型的问题的解决方案中的任何范围都将不胜感激。

Sub CompareSheets()
Application.ScreenUpdating = False
' constants
'  worksheets & ranges
'   original
Const ksWSOriginal = "ORIGINAL"
Const ksOriginal = "OriginalTable"
Const ksOriginalKey = "OriginalKey"
'   updated
Const ksWSUpdated = "UPDATED"
Const ksUpdated = "UpdatedTable"
Const ksUpdatedKey = "UpdatedKey"
'   changes
Const ksWSChanges = "CHANGES"
Const ksChanges = "ChangesTable"
'  labels
Const ksChange = "CHANGE"
Const ksRemove = "REMOVE"
Const ksAdd = "ADD"
'
' declarations
Dim rngO As Range, rngOK As Range, rngU As Range, rngUK As Range, rngC As Range
Dim c As Range
Dim I As Long, J As Long, lChanges As Long, lRow As Long, bEqual As Boolean
'
' start
Set rngO = Worksheets(ksWSOriginal).Range(ksOriginal) '(*)here gets marked the error of the debugger
Set rngOK = Worksheets(ksWSOriginal).Range(ksOriginalKey)
Set rngU = Worksheets(ksWSUpdated).Range(ksUpdated)
Set rngUK = Worksheets(ksWSUpdated).Range(ksUpdatedKey)
Set rngC = Worksheets(ksWSChanges).Range(ksChanges)
With rngC
    If .Rows.Count > 1 Then
        Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
        Range(.Rows(2), .Rows(.Rows.Count)).Font.ColorIndex = xlColorIndexAutomatic
        Range(.Rows(2), .Rows(.Rows.Count)).Font.Bold = False
    End If
End With
'
' process
lChanges = 1
'  1st pass: updates & deletions
With rngOK
    For I = 1 To .Rows.Count
        Set c = rngUK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
        If c Is Nothing Then
            ' deletion
            lChanges = lChanges + 1
            rngC.Cells(lChanges, 1).Value = ksRemove
            For J = 1 To rngO.Columns.Count
                rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
                rngC.Cells(lChanges, J + 1).Font.Color = vbRed
                rngC.Cells(lChanges, J + 1).Font.Bold = True
            Next J
        Else
            bEqual = True
            lRow = c.Row - rngUK.Row + 1
            For J = 1 To rngO.Columns.Count
                If rngO.Cells(I, J).Value <> rngU.Cells(lRow, J).Value Then
                    bEqual = False
                    Exit For
                End If
            Next J
            If Not bEqual Then
                ' change
                lChanges = lChanges + 1
                rngC.Cells(lChanges, 1).Value = ksChange
                For J = 1 To rngO.Columns.Count
                    If rngO.Cells(I, J).Value = rngU.Cells(lRow, J).Value Then
                        rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
                    Else
                        rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
                        rngC.Cells(lChanges, J + 1).Font.Color = vbMagenta
                        rngC.Cells(lChanges, J + 1).Font.Bold = True
                    End If
                Next J
            End If
        End If
    Next I
End With
'  2nd pass: additions
With rngUK
    For I = 1 To .Rows.Count
        Set c = rngOK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
        If c Is Nothing Then
            ' addition
            lChanges = lChanges + 1
            rngC.Cells(lChanges, 1).Value = ksAdd
            For J = 1 To rngU.Columns.Count
                rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
                rngC.Cells(lChanges, J + 1).Font.Color = vbBlue
                rngC.Cells(lChanges, J + 1).Font.Bold = True
            Next J
        End If
    Next I
End With
'
' end
Worksheets(ksWSChanges).Activate
rngC.Cells(2, 3).Select
Set rngC = Nothing
Set rngUK = Nothing
Set rngU = Nothing
Set rngOK = Nothing
Set rngO = Nothing
Beep
'
Application.ScreenUpdating = True
End Sub

另外，我测试了应用此解决方案的不同方法(LOOKUP，...(，但到目前为止，这是我最好的方法。

---

我已经找到了 CHANGE 状态的错误，并且与循环中的绝对引用有关，例如：ORIGINAL 选项卡在第 505 行参数中具有值Car_Red值为 23UPDATED 选项卡具有相同的参数 (Car_Red(，但在第 575 行中，值为 27代码注意到了差异，但它不会复制这个新值，而是从第 505 行的 UPDATED 选项卡中获取值(作为该值的原始选项卡位置(，所以我想我们需要另一个变量来捕获参数的新值以将其用作 UPDATED 选项卡的参考。

Answer 1

下面的摘录中的第一个列表存在错误。

rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value

应该是

rngC.Cells(lChanges, J + 1).Value = rngU.Cells(lRow, J).Value 

As I 是指Original文件中的行位置

，而lRow是指Update文件中匹配的条目行位置。

For J = 1 To rngO.Columns.Count
   If rngO.Cells(I, J).Value = rngU.Cells(lRow, J).Value Then
      rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
   Else
      rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
      rngC.Cells(lChanges, J + 1).Font.Color = vbMagenta
      rngC.Cells(lChanges, J + 1).Font.Bold = True
   End If
Next J

Answer 2

因此，由于信息未排序 VLOOKUP，索引匹配不适用于多个工作表，要更新此未排序列表中的正确信息，有必要创建一个额外的子：

Sub CopyRealChange()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tempName As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
Set sh1 = ActiveWorkbook.Worksheets("UPDATED")
Set sh2 = ActiveWorkbook.Worksheets("CHANGES")
lastRow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row    'Get last row for both sheets
lastRow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row    ' searching both
For s2Row = 2 To lastRow2                              'Loop through "CHANGES"
    If sh2.Cells(s2Row, 1).Value = "CHANGE" Then
        tempName = sh2.Cells(s2Row, 2).Value           'extra step for understanding concept
                                                       'There is a match, so now
        For s1Row = 2 To lastRow1                      'Search through the other sheet
            If sh1.Cells(s1Row, 1).Value = tempName Then
                sh2.Cells(s2Row, 3).Value = sh1.Cells(s1Row, 2).Value    'Copy Values
                sh2.Cells(s2Row, 4).Value = sh1.Cells(s1Row, 3).Value
            End If
        Next s1Row
    End If
Next s2Row

结束子

并且

发现在几乎所有比较案例中，都没有必要创建带有更改的第 4 个选项卡，因为更新的版本已经包含所有信息并且是多余的