替換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 

...這都應該在一行。