Capturing cell color change in VBA

[bdepolo]

Is there a way to capture a cell color change within an event in VBA? I've tried the worksheet change event, but when just changing the background color it doesn't trigger the event. Is there another event that would do this?

Thanks in advance!

 

[Damon Ostrander]

Hi bdepolo,

Sadly, there is no event to capture a cell color change. I'm assuming you are referring to a change in the interior fill color, rather than a change caused by conditional formatting. The latter can be captured by monitoring the conditional formatting condition in VBA.

Something that might come close would be to monitor changes to cell color each time the worksheet calculates. This would be very inefficient if a large number of cells had to be monitored for color changes, but if you are only interested in, for example, monitoring cells in a certain column or a limited range, the overhead shouldn't be too bad. Of course, the main problem with this approach is that the "capture" wouldn't occur until the next time the worksheet calculated--most likely when the contents of a cell was changed.

Let me know if you would like some code to monitor color change upon calculation.

Damon

 

[bdepolo]

Thank you for the reply Damon. Yeah it is unfortunate that Excel does not give a way to monitor color changes within a cell. I only need it to monitor a cell range of about 6 cells, so it's not a large area at all.

The problem being that I have some code to highlight certain rows of a spreadsheet that then have various columns subtotaled etc based on the shading. I have put in the ability for the user to change the shading color to their liking and would like to throw a warning when the same color is used for multiple groups. I was hoping to do this whenever there was a color change, but if the only way to do so is on a worksheet calculate I suppose that wouldn't be a huge problem.

If you would be able to post the code I would appreciate it.

Thanks!

 

[Jaafar Tribak]

You can try monitoring the cells colors inside a loop as follows

Option Explicit

Private bXitLoop As Boolean
Private bLoopRunning As Boolean

Public Sub WatchCellColor()

    Const MSG1 As String = "You Changed the Color of Range : "
    Const MSG2 As String = "Do you want to restore the previous color ?"
    Dim vCellCurColor() As Variant
    Dim vCellPrevColor() As Variant
    Dim sCellAddrss() As String
    Dim sVisbRngAddr As String
    Dim bAllCellsCounted As Boolean
    Dim oCell As Range
    Static i As Long
    
    bAllCellsCounted = False
    If bLoopRunning Then Exit Sub
    bXitLoop = False
    Do
        bLoopRunning = True
        i = -1
VisibleRngChanged:
        If sVisbRngAddr <> ActiveWindow.VisibleRange.Address _
        And sVisbRngAddr <> "" Then
            Erase sCellAddrss
            Erase vCellCurColor
            Erase vCellPrevColor
            sVisbRngAddr = ""
            bAllCellsCounted = False
            GoTo VisibleRngChanged
        End If
        On Error Resume Next
            For Each oCell In ActiveWindow.VisibleRange.Cells
                ReDim Preserve sCellAddrss(i + 1)
                ReDim Preserve vCellCurColor(i + 1)
                sCellAddrss(i + 1) = oCell.Address
                vCellCurColor(i + 1) = oCell.Interior.Color
                If vCellPrevColor(i + 1) <> vCellCurColor(i + 1) Then
                    If bAllCellsCounted = True Then
                        If MsgBox(MSG1 & oCell.Address & vbNewLine & MSG2, vbQuestion + vbYesNo) _
                        = vbYes Then
                            oCell.Interior.Color = vCellPrevColor(i + 1)
                            vCellCurColor(i + 1) = vCellPrevColor(i + 1)
                        End If
                    End If
                End If
                i = i + 1
                If i + 1 >= ActiveWindow.VisibleRange.Cells.Count Then
                    bAllCellsCounted = True
                    ReDim Preserve vCellPrevColor(UBound(vCellCurColor))
                    vCellPrevColor = vCellCurColor
                    End If
                vCellPrevColor(i + 1) = vCellCurColor(i + 1)
            Next
        On Error GoTo 0
        sVisbRngAddr = ActiveWindow.VisibleRange.Address
        DoEvents
    Loop Until bXitLoop
    bLoopRunning = False

End Sub

Public Sub StopWatching()

    bXitLoop = True

End Sub

If you like this , I can try and improve it by using a timer which is a better approach.

 

[Damon Ostrander]

Thanks Jaafar, for stepping in with a solution.

bdepolo, did you try Jaafar's solution? It looks like if you want to make it more efficient and limit it to a small range you can change ActiveWindow.VisibleRange everywhere in Jaafar's code to the specific range of interest, for example Range("C3:C8").

Damon

 

[Jaafar Tribak]

For the sake of completeness here is a more robust solution that doesn't work with a loop and doesn't potentially crash :

Workbook demo.

1- Add a new Class module to the project and give it the name of "C_CellColorChange"
Put this in the class module :

Option Explicit
Private WithEvents cmb As Office.CommandBars
Private bCancel As Boolean
Private bAllCellsCounted As Boolean
Private vCellCurColor() As Variant
Private vCellPrevColor() As Variant
Private sCellAddrss() As String
Private sVisbRngAddr As String
Private i As Long
Private oSh As Worksheet
Private oCell As Range

Public Sub ApplyToSheet(Sh As Worksheet)
    Set oSh = Sh
End Sub

Public Sub StartWatching()
    Set cmb = Application.CommandBars
End Sub

Private Sub Class_Initialize()
    bAllCellsCounted = False
End Sub


Private Sub cmb_OnUpdate()

    If Not ActiveSheet Is oSh Then Exit Sub
    bCancel = False
    i = -1
VisibleRngChanged:
    If sVisbRngAddr <> ActiveWindow.VisibleRange.Address _
        And sVisbRngAddr <> "" Then
        Erase sCellAddrss
        Erase vCellCurColor
        Erase vCellPrevColor
        sVisbRngAddr = ""
        bAllCellsCounted = False
        GoTo VisibleRngChanged
    End If
    On Error Resume Next
        For Each oCell In ActiveWindow.VisibleRange.Cells
            ReDim Preserve sCellAddrss(i + 1)
            ReDim Preserve vCellCurColor(i + 1)
            sCellAddrss(i + 1) = oCell.Address
            vCellCurColor(i + 1) = oCell.Interior.Color
            If vCellPrevColor(i + 1) <> vCellCurColor(i + 1) Then
                If bAllCellsCounted = True Then
                    oCell.Interior.Color = vCellPrevColor(i + 1)
                    CallByName oSh, _
                    "CellColorChanged", VbMethod, oCell, _
                    oCell.Interior.Color, bCancel
                    If Not bCancel Then
                        oCell.Interior.Color = vCellCurColor(i + 1)
                        vCellPrevColor(i + 1) = vCellCurColor(i + 1)
                    Else
                        oCell.Interior.Color = vCellPrevColor(i + 1)
                        vCellCurColor(i + 1) = vCellPrevColor(i + 1)
                    End If
                    bCancel = False
                End If
            End If
                i = i + 1
            If i + 1 >= ActiveWindow.VisibleRange.Cells.Count Then
                bAllCellsCounted = True
                ReDim Preserve vCellPrevColor(UBound(vCellCurColor))
                vCellPrevColor = vCellCurColor
            End If
            vCellPrevColor(i + 1) = vCellCurColor(i + 1)
        Next
    On Error GoTo 0
        sVisbRngAddr = ActiveWindow.VisibleRange.Address

End Sub

2- This goes in the worksheet module where the cells are being monitored for color changes :

Option Explicit
Private oCellColorMonitor As C_CellColorChange

Public Sub CellColorChanged(Cell As Range, Color As Variant, Cancel As Boolean)
    
    Const MSG1 As String = "You are trying to change the Color of Range : "
    Const MSG2 As String = "Do you want to go ahead ?"
    
    If MsgBox(MSG1 & Cell.Address & vbNewLine & MSG2, vbQuestion + vbYesNo) _
    = vbNo Then
        Cancel = True
    End If

End Sub


Private Sub StartWatching_Click()
    Set oCellColorMonitor = New C_CellColorChange
    oCellColorMonitor.ApplyToSheet Me
    oCellColorMonitor.StartWatching
End Sub

Private Sub StopWatching_Click()
    Set oCellColorMonitor = Nothing
End Sub

Note that this only works for the cells in the Visible Range . The smaller the Visible Range the more efficient the code.

 

[jamilm]

Hi Jafar,

this is good, but i want the logs to be saved in the sheet "Log" can you please help, i have already a code in the worksheet change event but i want the color backgound change to be logged. my post http://www.mrexcel.com/forum/excel-...s-new-sheet-private-sub-worksheet_change.html

thanks.

 

[Jaafar Tribak]

Hi Jafar,

this is good, but i want the logs to be saved in the sheet "Log" can you please help, i have already a code in the worksheet change event but i want the color backgound change to be logged. my post http://www.mrexcel.com/forum/excel-...s-new-sheet-private-sub-worksheet_change.html

thanks.

Hi jamilm,

Here is a WORKBOOK DEMO

Code:


1: Add a new Class module to your Project , give it the name of C_CellColorChange and plce this code in it :

Option Explicit
Private WithEvents cmb As Office.CommandBars
Private bCancel As Boolean
Private bAllCellsCounted As Boolean
Private vCellCurColor() As Variant
Private vCellPrevColor() As Variant
Private sCellAddrss() As String
Private sVisbRngAddr As String
Private i As Long
Private oSh As Worksheet
Private oCell As Range

Public Sub ApplyToSheet(Sh As Worksheet)
    Set oSh = Sh
End Sub

Public Sub StartWatching()
    Set cmb = Application.CommandBars
End Sub

Private Sub Class_Initialize()
    bAllCellsCounted = False
End Sub


Private Sub cmb_OnUpdate()

    If Not ActiveSheet Is oSh Then Exit Sub
    bCancel = False
    i = -1
VisibleRngChanged:
    If sVisbRngAddr <> ActiveWindow.VisibleRange.Address _
        And sVisbRngAddr <> "" Then
        Erase sCellAddrss
        Erase vCellCurColor
        Erase vCellPrevColor
        sVisbRngAddr = ""
        bAllCellsCounted = False
        GoTo VisibleRngChanged
    End If
    On Error Resume Next
        For Each oCell In ActiveWindow.VisibleRange.Cells
            ReDim Preserve sCellAddrss(i + 1)
            ReDim Preserve vCellCurColor(i + 1)
            sCellAddrss(i + 1) = oCell.Address
            vCellCurColor(i + 1) = oCell.Interior.Color
            If vCellPrevColor(i + 1) <> vCellCurColor(i + 1) Then
                If bAllCellsCounted = True Then
                    oCell.Interior.Color = vCellPrevColor(i + 1)
                    CallByName ThisWorkbook, _
                    "CellColorChanged", VbMethod, oCell, _
                    oCell.Interior.Color, vCellCurColor(i + 1), bCancel
                    If Not bCancel Then
                        oCell.Interior.Color = vCellCurColor(i + 1)
                        vCellPrevColor(i + 1) = vCellCurColor(i + 1)
                    Else
                        oCell.Interior.Color = vCellPrevColor(i + 1)
                        vCellCurColor(i + 1) = vCellPrevColor(i + 1)
                    End If
                    bCancel = False
                End If
            End If
                i = i + 1
            If i + 1 >= ActiveWindow.VisibleRange.Cells.Count Then
                bAllCellsCounted = True
                ReDim Preserve vCellPrevColor(UBound(vCellCurColor))
                vCellPrevColor = vCellCurColor
            End If
            vCellPrevColor(i + 1) = vCellCurColor(i + 1)
        Next
    On Error GoTo 0
        sVisbRngAddr = ActiveWindow.VisibleRange.Address

End Sub

2: Place the following code in the Thisworkbook Module :

Option Explicit
Private oCellColorMonitor As C_CellColorChange

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call StopWatching
End Sub

Private Sub Workbook_Open()
    Call StartWatching
End Sub

Public Sub CellColorChanged(Cell As Range, PrevColor As Variant, NewColor As Variant, Cancel As Boolean)
    
    Const MSG1 As String = "You are trying to change the Color of Range : "
    Const MSG2 As String = "Do you want to go ahead ?"
    
    If MsgBox(MSG1 & Cell.Address & vbNewLine & MSG2, vbQuestion + vbYesNo) _
    = vbNo Then
        Cancel = True
    Else
        With Sheets("Log")
            .Cells(1, 1).End(xlDown).Offset(1) = Cell.Address
            .Cells(1, 1).End(xlDown).Offset(0, 1).Interior.Color = PrevColor
            .Cells(1, 1).End(xlDown).Offset(0, 2).Interior.Color = NewColor
            .Cells(1, 4).End(xlDown).Offset(1) = Format(Date, "dd/mm/yyyy") & _
            " @ " & Format(Time, "hh: mm: ss ")
            .Cells(1, 5).End(xlDown).Offset(1) = Environ("Username")
        End With
    End If

End Sub


Private Sub StartWatching()
    Set oCellColorMonitor = New C_CellColorChange
    oCellColorMonitor.ApplyToSheet Sheets(1) [B][COLOR=#00ff00]'change target sheet as required [/COLOR][/B]
    oCellColorMonitor.StartWatching
End Sub

Private Sub StopWatching()
    Set oCellColorMonitor = Nothing
End Sub

The code assumes that the workbook has already a worksheet named "Log" with the first 2 rows and the first 5 columns reserved for the log headings (See workbook demo)

 

[FlyFishn4Bass]

Like bdepelo, I want to give the user a chance to change a half dozen colors so the user can tailor certain display items. To do this, I create my own event ... sort of.
I display 2 sets of colors. The first set is labeled "current colors", the second set is labeled "new colors". I also provide the user with a "submit" button. That button is my pseudo event.