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

Question

I have an Excel Macro below that I am using and it highlights the entire row yellow and the cell changed red when a change is made. It also is set up that if an additional cell is changed on the same row, the row stays yellow, the first changed cell stays red and the second cell changed is also turned red. The Macro works when you change a cell manually or copy and paste another cell.

The problem is that when I copy and paste more than one cell to a line, these highlighting features do not work. Does anyone know how I can modify the below Macro to also highlight the line yellow and make all cells copy and pasted red? I still would like the function that if I change another cell on the same line, it will keep all previously changed cells yellow and red on that line. Thanks in advance!

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 (Whole Worksheets)

• The following is easily tested:

  • Copy the code into the ThisWorkbook module of a new workbook.
  • Start entering, copy/pasting data on any worksheet and see what happens.

• This one will not color yellow if to the right of the last yellow or red colored cell in the same row.

The Code

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

• This one will not retain the previous red colors to the left.

The Code

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