Question

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

ORIGINAL \ UPDATED \ CHANGES

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

即： ORIGINAL \ UPDATED \ CHANGED

Car_01 | 500 | ms \ Car_01 | 750 | ms \ 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 的值为 23 UPDATED选项卡具有相同的参数（ Car_Red ），但在行575 中，值 27 代码注意到差异，但不是复制这个新值，而是从 505 行中的UPDATED选项卡中获取值（作为该值的ORIGINAL选项卡位置），所以我想我们不知何故需要另一个变量来捕获参数的新值，以将其用作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

由于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，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

End Sub

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

EXCEL VBA：比较然后更新/更改，删除和添加两张纸

2 个答案: