Excelで変更された値を置き換えます。

Question

次のマクロを使用して、2つのスプレッドシート間の週単位の変更を比較し、変更を3番目のシートにダンプします。ただし、変更された値だけを元の行と次に別の行にダンプし、両方の値を強調表示します。変更された値で1行だけをダンプするにはどうしたらいいですか？私は2つの行やオリジナルと変更された値を表示する必要はありません、完全に新しい変更された値で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 

だからそれをコメントアウト。

あなたにTHEN文をIF bChangedを変更した場合：

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 

...それはすべて1行にする必要があります。