0

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
Improve this question
4
  • 1
    If .CountLarge = 1 Then means that this functionality only works if Target is one cell. Commented Nov 4, 2020 at 17:18
  • 1
    Maybe start by changing that to If .Rows.Count = 1 Then That should do it. Commented Nov 4, 2020 at 17:50
  • Your logic is either flawed or insufficiently explained. (1) If you want to mark changed cells you need to capture the change of each cell individually. Your code does that. (2) If you paste several cells all pasted cells get changed even if their new values are the same as before. All cells would turn red in that action. Therefore, if you want to paste more than one cell you need to keep the solution you have and get another macro to respond to that action. Commented Nov 5, 2020 at 0:37
  • A macro that allows you to paste and then mark the changes would need to record the existing values before the paste action, then compare old and new, and finally mark the changes. If you want to paste a single row the Selection_Change event can be used to keep a copy of existing values as a base for comparison. But consider changing your workflow. The data you copy must be in the same version of Excel. Can't you transfer them by another method, such as select the source and then run a macro to do the transfer? Commented Nov 5, 2020 at 0:43

1 Answer 1

Reset to default
0

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
Improve this answer
Sign up to request clarification or add additional context in comments.

2 Comments

Hi VBasic2008, the first code works and I was trying the second one but I am getting an error on "collectRanges" that says "The keyword you selected can't be found in Visual Basic Help. You may have misspelled the keyword, selected too much or too little text, or asked for help on a word that isn't a valid Visual Basic keyword." Can you please check that one?
Also on the first answer, it does work but when I push my button to clear the red and yellow highlights and remove my timestamps that Macro no longer works. It is supposed to remove the times stamps in Column A and now it is turing all the cells red and is not removing the yellow cells. Can you correct the first answer to not let it do that when I push my button? This is my Macro to clear the highlights and timestamps in column A:

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.