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

我比较同一工作簿中的2个工作表，逐行（和行的每个单元格）这个代码，它能够识别哪一行已经改变（CHANGE），如果不存在于第二张纸上，则显示它被删除（REMOVE），或者如果这只存在于第二个工作表中，则需要添加（ADD）。 所以工作表中的标签是：

ORIGINAL \ UPDATED \ CHANGES

我想要实现的是创build第四个（最终）应用所有的变化，但在我甚至可以到达那里之前，我发现代码的一些问题（顺便说一句在这里发现的源代码和模板）它很好（与REMOVE和ADD），但是在使用大量registry（数百个）时，其中一些标记为更改不会显示正确的值，有时候，在相同的选项卡中重新处理并尝试再次应用macros时出错标记的行（*）。

IE：ORIGINAL \ UPDATED \ CHANGED

Car_01 | 500 | ms \ Car_01 | 750 | ms \ Car_01 | 15.5 | 女士

起初，我认为这是一个问题，认为它是与单元格的参数types相关的input，它必须在macros中，但到目前为止我还没有find正确的types（已经有尝试：General，Number和文本）。 因此，在解决如何显示第四个表格和值types的问题的任何范围将非常感激。

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 

作为补充说明，我testing了不同的方法来应用这个解决scheme（LOOKUP，…），但到目前为止，这是我最好的方法。

---

我find了CHANGE状态的错误，并且与循环中的绝对引用相关，例如：ORIGINAL选项卡在第505行参数中具有值Car_Red具有值23 UPDATED选项卡具有相同的参数（ Car_Red ），但是在值为27的行575代码注意到了这个差异，但是不是复制这个新值，而是从行505中的UPDATED选项卡（作为该值的ORIGINAL选项卡位置）获取值，所以我猜想我们需要另一个variables来捕获参数的新值，以将其用作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

所以，因为信息没有sortingVLOOKUP，INDEX-MATCH不适用于多个工作表，要更新这个未sorting列表中的正确的信息，有必要创build一个额外的子：

 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 

结束小组

几乎在每一个比较中发现，没有必要创build一个第四个选项卡，因为更新后的版本已经包含所有的信息，并且是多余的