Excel 复制和粘贴多个单元格时自动高亮显示多个单元格_Excel_Vba_Cell_Highlight

Excel 复制和粘贴多个单元格时自动高亮显示多个单元格

excel vba

Excel 复制和粘贴多个单元格时自动高亮显示多个单元格,excel,vba,cell,highlight,Excel,Vba,Cell,Highlight,下面有一个我正在使用的Excel宏，当进行更改时，它将整行高亮显示为黄色，单元格变为红色。还可以设置，如果在同一行上更改了其他单元格，则该行保持黄色，第一个更改的单元格保持红色，第二个更改的单元格也变为红色。手动更改单元格或复制并粘贴另一个单元格时，宏起作用问题是，当我将多个单元格复制并粘贴到一行时，这些高亮显示功能不起作用。有人知道我如何修改下面的宏以同时高亮显示黄色线条，并使所有单元格复制并粘贴为红色吗？我仍然希望这个函数，如果我在同一行上更改另一个单元格，它将保持该行上所有先前更改的单元

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

Private子工作簿\u SheetChange（ByVal Sh作为对象，ByVal Target作为范围）
尺寸Cl为“最后使用的长”列
有目标
如果.CountLarge=1，则
'将.Row更改为使用时间最长的行号
'如果您的行长度不一致
如果是Sh.Cells（.Row，“A”）.Interior.Color vbYellow和_
Sh.Cells（.Row，“A”）.Interior.Color vbRed然后
Cl=Sh.Cells（.Row，Columns.Count）.End（xlToLeft）.Column
Sh.Range（Sh.Cells（.Row，1），Sh.Cells（.Row，Cl））.Interior.Color=vbYellow
如果结束
.Interior.Color=vbRed
如果结束
以
端接头

工作簿\u表单更改（整个工作表）

以下内容易于测试：
- 将代码复制到新工作簿的
```
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, 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

Private子工作簿\u SheetChange（ByVal Sh作为对象，ByVal Target作为范围）
'初始化错误处理。
Const ProcName As String=“工作簿\u图纸更改”
关于错误转到clearError
Const FirstCol As String=“A”
变暗tgt As范围
设置tgt=Target
变暗yRng为“黄色范围”
变暗rRng为“红色范围”
将rng调暗为“区域中的每个范围”
Dim cel作为范围“范围内的每个单元格
将LastCol设置为“长”当前最后一列
变暗电流为长“当前行
'关于错误转到clearError
Application.EnableEvents=False
对于tgt.区域内的每个rng
对于rng.单元格中的每个单元格
CurRow=小区行
如果Sh.Cells（CurRow，FirstCol）.Interior.Color为红色，则
如果是Sh.Cells（CurRow，FirstCol）.Interior.Color vbYellow_
然后
LastCol=Sh.Cells（CurRow，Columns.Count）_
.End（xlToLeft）.列
收集_
Sh.Range（Sh.Cells（CurRow，FirstCol）_
Sh.Cells（CurRow，LastCol））
如果结束
英国皇家海军陆战队
如果结束
下一个细胞
下一个rng
如果不是的话yRng什么都不是
yRng.Interior.Color=vbYellow
如果结束
如果不是rRng，那就什么都不是了
rRng.Interior.Color=vbRed
如果结束
安全出口：
Application.EnableEvents=True
转到出口
clearError：
Debug.Print“'”&ProcName&“：”&vbLf_
&“&”运行时错误“&”错误编号&“：”&vbLf_
&“”错误描述（&R）
错误转到0
转到安全出口
程序出口：
端接头
私有子集合范围（ByRef TotalRange作为范围_
添加范围作为范围）
如果不是TotalRange，则为Nothing
设置TotalRange=Union（TotalRange，AddRange）
其他的
设置TotalRange=AddRange
如果结束
端接头
子切换对象（）
如果是Application.EnableEvents，则
Application.EnableEvents=False
其他的
Application.EnableEvents=True
如果结束
端接头

这一个将不会保留以前左侧的红色

代码

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

Private子工作簿\u SheetChange（ByVal Sh作为对象，ByVal Target作为范围）
'初始化错误处理。
Const ProcName As String=“工作簿\u图纸更改”
关于错误转到clearError
Const FirstCol As String=“A”
变暗tgt As范围
设置tgt=Target
变暗yRng为“黄色范围”
变暗rRng为“红色范围”
将rng调暗为“区域中的每个范围”
Dim cel作为范围“范围内的每个单元格
将LastCol设置为“长”当前最后一列
Application.EnableEvents=False
使用CreateObject（“Scripting.Dictionary”）
对于tgt.区域内的每个rng
对于rng.单元格中的每个单元格
如果cel.Interior.Color为红色，则
如果cel.Interior.Color为黄色，则
如果不存在（cel.Row），则
.添加单元格。行，空
LastCol=Sh.Cells（cel.Row，Columns.Count）_
.End（xlToLeft）.列
收集_
Sh.范围（Sh.单元格（单元格行、第一列）_
Sh.Cells（cel.Row，LastCol））
如果结束
如果结束
英国皇家海军陆战队
如果结束
下一个细胞
下一个rng
以
如果不是的话yRng什么都不是
yRng.Interior.Color=vbYellow
如果结束
如果不是rRng，那就什么都不是了
rRng.Interior.Color=vbRed
如果结束
安全出口：
Application.EnableEvents=True
转到出口
clearError：
Debug.Print“'”&ProcName&“：”&vbLf_
&“&”运行时错误“&”错误编号&“：”&vbLf_
&“”错误描述（&R）