复制和粘贴多个单元格时自动突出显示多个单元格

Question

我下面有一个我正在使用的 Excel 宏，它突出显示了整行黄色，并且在进行更改时单元格变为红色。它还设置为如果在同一行上更改了其他单元格，则该行保持黄色，第一个更改的单元格保持红色，第二个更改的单元格也变为红色。当您手动更改单元格或复制并粘贴另一个单元格时，宏会起作用。

问题是当我将多个单元格复制并粘贴到一行时，这些突出显示功能不起作用。有谁知道我如何修改下面的宏以突出显示黄色行并使所有单元格复制并粘贴为红色？我仍然想要这样的功能，如果我更改同一行上的另一个单元格，它将使该行上所有先前更改的单元格保持黄色和红色。提前致谢！

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Cl      As Long                 ' last used column
With Target
    If .CountLarge = 1 Then
        ' change .Row to longest used row number
        ' if your rows aren't of uniform length
        If Sh.Cells(.Row, "A").Interior.Color <> vbYellow And _
           Sh.Cells(.Row, "A").Interior.Color <> vbRed Then
            Cl = Sh.Cells(.Row, Columns.Count).End(xlToLeft).Column
            Sh.Range(Sh.Cells(.Row, 1), Sh.Cells(.Row, Cl)).Interior.Color = vbYellow
        End If
        .Interior.Color = vbRed
    End If
 End With
End Sub

Answer 1

Workbook_SheetChange（整个工作表）

下面很容易测试：
- 将代码复制到新工作簿的 ThisWorkbook 模块中。
- 开始在任何工作表上输入 copy/pasting 数据，看看会发生什么。
如果在同一行中最后一个黄色或红色单元格的右侧，这个单元格不会变成黄色。

代码

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    ' Initialize error handling.
    Const ProcName As String = "Workbook_SheetChange"
    On Error GoTo clearError
    
    Const FirstCol As String = "A"
    
    Dim tgt As Range
    Set tgt = Target
    
    Dim yRng As Range   ' Yellow Range
    Dim rRng As Range   ' Red Range
    Dim rng As Range    ' Each Range in Areas
    Dim cel As Range    ' Each Cell in Range
    Dim LastCol As Long ' Current Last Column
    Dim CurRow As Long  ' Current Row
    
    'On Error GoTo clearError
    Application.EnableEvents = False
    
    For Each rng In tgt.Areas
        For Each cel In rng.Cells
            CurRow = cel.Row
            If Sh.Cells(CurRow, FirstCol).Interior.Color <> vbRed Then
                If Sh.Cells(CurRow, FirstCol).Interior.Color <> vbYellow _
                  Then
                    LastCol = Sh.Cells(CurRow, Columns.Count) _
                                .End(xlToLeft).Column
                    collectRanges yRng, _
                      Sh.Range(Sh.Cells(CurRow, FirstCol), _
                               Sh.Cells(CurRow, LastCol))
                End If
                collectRanges rRng, cel
            End If
        Next cel
    Next rng
    
    If Not yRng Is Nothing Then
        yRng.Interior.Color = vbYellow
    End If
    If Not rRng Is Nothing Then
        rRng.Interior.Color = vbRed
    End If
    
SafeExit:
    Application.EnableEvents = True
    GoTo ProcExit

clearError:
    Debug.Print "'" & ProcName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0
    GoTo SafeExit

ProcExit:

End Sub

Private Sub collectRanges(ByRef TotalRange As Range, _
                          AddRange As Range)
    If Not TotalRange Is Nothing Then
        Set TotalRange = Union(TotalRange, AddRange)
    Else
        Set TotalRange = AddRange
    End If
End Sub

Sub toggleEE()
    If Application.EnableEvents Then
        Application.EnableEvents = False
    Else
        Application.EnableEvents = True
    End If
End Sub

这个不会保留之前左边的红色。

代码

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    ' Initialize error handling.
    Const ProcName As String = "Workbook_SheetChange"
    On Error GoTo clearError
    
    Const FirstCol As String = "A"
    
    Dim tgt As Range
    Set tgt = Target
    
    Dim yRng As Range   ' Yellow Range
    Dim rRng As Range   ' Red Range
    Dim rng As Range    ' Each Range in Areas
    Dim cel As Range    ' Each Cell in Range
    Dim LastCol As Long ' Current Last Column

    Application.EnableEvents = False
    
    With CreateObject("Scripting.Dictionary")
        For Each rng In tgt.Areas
            For Each cel In rng.Cells
                If cel.Interior.Color <> vbRed Then
                    If cel.Interior.Color <> vbYellow Then
                        If Not .Exists(cel.Row) Then
                            .Add cel.Row, Empty
                            LastCol = Sh.Cells(cel.Row, Columns.Count) _
                                        .End(xlToLeft).Column
                            collectRanges yRng, _
                              Sh.Range(Sh.Cells(cel.Row, FirstCol), _
                                       Sh.Cells(cel.Row, LastCol))
                        End If
                    End If
                    collectRanges rRng, cel
                End If
            Next cel
        Next rng
    End With
    
    If Not yRng Is Nothing Then
        yRng.Interior.Color = vbYellow
    End If
    If Not rRng Is Nothing Then
        rRng.Interior.Color = vbRed
    End If
    
SafeExit:
    Application.EnableEvents = True
    GoTo ProcExit

clearError:
    Debug.Print "'" & ProcName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0
    GoTo SafeExit

ProcExit:

End Sub

复制和粘贴多个单元格时自动突出显示多个单元格

Highlighting multiple cells automatically when copy and paste more than one cell

excel

vba

highlight

cell

Workbook_SheetChange（整个工作表）