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

......它应该都在一行中。

在Excel中替换更改的值

1 个答案: