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

编程问答 2022-06-04

问题描述

我在下面使用一个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

解决方法

Workbook_SheetChange（整个工作表）

  • 以下内容易于测试：

    • 将代码复制到新工作簿的ThisWorkbook模块中。
    • 开始在任何工作表上输入，复制/粘贴数据，然后看看会发生什么。

  • 如果该像素位于同一行中最后一个黄色或红色单元格的右边，则不会将其着色为黄色。

代码 

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,_
                                       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
cellcellcellexcelexcelhighlightvba