替换Excel中的更改值

Question

我使用以下宏来比较2个电子表格之间每周和每周的更改，并将更改转储到第3个工作表。然而，它仅转储原始行，然后是仅更改了值的另一行，并突出显示这两个值。我怎样才能得到它只需转储1行与更改的值？我不需要两行或显示的原始值和更改值，只需要1行，并具有完整的新更改值。

Option Explicit 
Dim miMaxColumns As Integer 
Sub CompareSheets() 
Dim bChanged As Boolean, baChanged() As Boolean 
Dim iColEnd As Integer, iCol As Integer, iCol1 As Integer, iCol2 As Integer 
Dim lRow1 As Long, lRow2 As Long, lReportRow As Long 
Dim objDictOld As Object, objDictNew As Object 
Dim vKeys As Variant, vKey As Variant 
Dim vaInput() As Variant, vaOutput() As Variant, vaOutput2() As Variant 
Dim vaInputOld As Variant, vaInputNew As Variant 
Dim wsOld As Worksheet, wsNew As Worksheet, wsReport As Worksheet 


Set wsOld = Sheets("Sheet1") 
miMaxColumns = wsOld.Cells(1, Columns.Count).End(xlToLeft).Column 
Set objDictOld = PopulateDictionary(WS:=wsOld) 
Set wsNew = Sheets("Sheet2") 
Set objDictNew = PopulateDictionary(WS:=wsNew) 

Set wsReport = Sheets("Sheet3") 

With wsReport 
    .Cells.ClearFormats 
    .Cells.ClearContents 
End With 

wsOld.Range("A1:" & wsOld.Cells(1, miMaxColumns).Address).Copy 
wsReport.Range("B1").PasteSpecial xlPasteValues 
Application.CutCopyMode = False 

lReportRow = 1 
vKeys = objDictOld.Keys 
For Each vKey In vKeys 
    ReDim vaInputOld(1 To 1, 1 To miMaxColumns) 
    vaInputOld = objDictOld.Item(vKey) 
    If objDictNew.exists(vKey) Then 
     ReDim vaInputNew(1 To 1, 1 To miMaxColumns) 
     vaInputNew = objDictNew.Item(vKey) 
     ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1) 
     ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1) 
     ReDim baChanged(1 To miMaxColumns) 
     bChanged = False 
     For iCol = 1 To miMaxColumns 
      vaOutput(1, iCol + 1) = vaInputOld(1, iCol) 
      If vaInputOld(1, iCol) <> vaInputNew(1, iCol) Then 
       vaOutput2(1, iCol + 1) = vaInputNew(1, iCol) 
       baChanged(iCol) = True 
       bChanged = True 
      End If 
     Next iCol 
     If bChanged Then 
      lReportRow = lReportRow + 1 
      For iCol = 1 To UBound(baChanged) 
       If baChanged(iCol) Then 
        With wsReport 
         .Range(.Cells(lReportRow, iCol + 1).Address, _ 
           .Cells(lReportRow + 1, iCol + 1).Address).Interior.Color = vbYellow 
        End With 
       End If 
      Next iCol 

      vaOutput(1, 1) = "Changed" 
      With wsReport 
       .Range(.Cells(lReportRow, 1).Address, _ 
         .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput 
       lReportRow = lReportRow + 1 
       .Range(.Cells(lReportRow, 1).Address, _ 
         .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2 
      End With 
     End If 
     objDictOld.Remove vKey 
     objDictNew.Remove vKey 
    Else 
     ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1) 
     vaOutput(1, 1) = "Deleted" 
     For iCol = 1 To miMaxColumns 
      vaOutput(1, iCol + 1) = vaInputOld(1, iCol) 
     Next iCol 

     lReportRow = lReportRow + 1 
     With wsReport 
      .Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput 
      '-- Set the row to light grey 
      .Range(.Cells(lReportRow, 2).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 15 
     End With 
    End If 
Next vKey 

If objDictNew.Count <> 0 Then 
    vKeys = objDictNew.Keys 
    For Each vKey In vKeys 
     ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1) 
     vaInputNew = objDictNew.Item(vKey) 
     vaOutput2(1, 1) = "Inserted" 
     For iCol = 1 To miMaxColumns 
      vaOutput2(1, iCol + 1) = vaInputNew(1, iCol) 
     Next iCol 
     lReportRow = lReportRow + 1 
     With wsReport 
      .Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2 
      '-- Set the row to light green 
      .Range(.Cells(lReportRow, 2).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 4 
     End With 
    Next vKey 
End If 

objDictOld.RemoveAll 
Set objDictOld = Nothing 
objDictNew.RemoveAll 
Set objDictNew = Nothing 
End Sub 
Private Function PopulateDictionary(ByRef WS As Worksheet) As Object 
Dim lRowEnd As Long, lRow As Long 
Dim rCur As Range 
Dim sKey As String 

Set PopulateDictionary = Nothing 
Set PopulateDictionary = CreateObject("Scripting.Dictionary") 
lRowEnd = WS.Cells(Rows.Count, "A").End(xlUp).Row 
For lRow = 2 To lRowEnd 
    sKey = Trim$(LCase$(CStr(WS.Range("A" & lRow).Value))) 
    On Error Resume Next 
    PopulateDictionary.Add Key:=sKey, Item:=WS.Range(WS.Cells(lRow, 1).Address, _ 
              WS.Cells(lRow, miMaxColumns).Address).Value 
    On Error GoTo 0 
Next lRow 
End Function 

Answer 1

这是 “旧” 值粘贴：

wsReport.Range("B1").PasteSpecial xlPasteValues 

所以只是发表意见说出来。

如果你改变了IF bChanged THEN声明：

If bChanged Then 
     For iCol = 1 To UBound(baChanged) 
      If baChanged(iCol) Then 
       With wsReport 
        .Range(.Cells(lReportRow, iCol + 1).Address, _ 
          .Cells(lReportRow, iCol + 1).Address).Interior.Color = vbYellow 
       End With 
      End If 
     Next iCol 

     vaOutput(1, 1) = "Changed" 
     With wsReport 
      .Range(.Cells(lReportRow, 1).Address, _ 
        .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput 

      For iCol = 1 To UBound(baChanged) 
       If baChanged(iCol) Then 
        With wsReport 
         .Range(.Cells(lReportRow, iCol + 1).Address, _ 
           .Cells(lReportRow, iCol + 1).Address).Value = vaOutput2(1, iCol + 1) 
        End With 
       End If 
      Next iCol 
     End With 
     lReportRow = lReportRow + 1 
    End If 

...这都应该在一行。