EXCEL VBA：比较然后更新/更改、删除和添加 2 张纸答案

【问题标题】：EXCEL VBA: Compare then Update/change, remove and add between 2 sheetsEXCEL VBA：比较然后更新/更改、删除和添加 2 张纸
【发布时间】：2014-12-05 21:01:15
【问题描述】：

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

原始\更新\更改

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

即：原始\更新\更改

汽车_01 |500| ms \ Car_01 |750 |ms \ Car_01| 15.5|毫秒

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

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 的值为 23 UPDATED 选项卡具有相同的参数 (Car_Red)，但在 第 575 行 中，值为 27 代码注意到了差异，但它不会复制这个新值，而是从行 505 中的 UPDATED 选项卡中获取值（作为该值的原始选项卡位置），所以我猜想我们需要另一个变量来捕获参数的新值，以将其用作 UPDATED 选项卡的参考。

【问题讨论】：

标签： vba excel

【解决方案1】：

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

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

应该是

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

因为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

【讨论】：

【解决方案2】：

因此，由于信息未按 VLOOKUP 排序，因此 INDEX-MATCH 不适用于多张工作表，要更新此未排序列表中的正确信息，必须创建一个额外的子：

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 个选项卡，因为更新的版本已经包含所有信息并且是多余的

【讨论】：