Private Sub Worksheet_SelectionChange(ByVal Target As Range): by color?

[JohanL]

[h=2]Hi Excel-experts,[/h][h=2]i find this code on internet:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)[/h]Is it possible to run anything like this, but then for 'Colour change in cells'?
I would like my sheet to react on change of backround colour in some specific cells.

Thanks in advance,
Johan

 

[Fluff]

Hi & welcome to MrExcel.
Unfortunately there is no event to detect a change of colour

 

[Jaafar Tribak]

Actually, with a bit of trickey, you can imitate an event to detect a change in cell color with a Cancel argument to undo the color change if needed.

Code goes in the ThisWorkbook Module

Option Explicit

Private WithEvents cmbrs As CommandBars

Private Sub Workbook_Activate()
    Set cmbrs = Application.CommandBars
    Call cmbrs_OnUpdate
End Sub

Private Sub Workbook_Deactivate()
    Set cmbrs = Nothing
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set cmbrs = Nothing
    Set cmbrs = Application.CommandBars
    Call cmbrs_OnUpdate
End Sub

Private Function RPad(ByVal sString As String, ByVal NumOfChrs As Long) As String
   RPad = Left(sString & Space(NumOfChrs), NumOfChrs)
End Function

Private Sub cmbrs_OnUpdate()
        
    Static sPrevVisibleRangeColorIndexes As String
    Static oPrevVisibleRange As Range
    Dim sCurVisibleRangeColorIndexes As String, sTempColorIndex As String
    Dim oCell As Range, bCancelArgument As Boolean
        
    On Error Resume Next
    
    For Each oCell In ActiveWindow.VisibleRange.Cells
        sCurVisibleRangeColorIndexes = sCurVisibleRangeColorIndexes & CStr(oCell.Interior.ColorIndex)
    Next oCell
    If Len(sPrevVisibleRangeColorIndexes) <> 0 Then
        If sCurVisibleRangeColorIndexes <> sPrevVisibleRangeColorIndexes Then        
        If oPrevVisibleRange.Address = ActiveWindow.VisibleRange.Address Then
            Call OnCellColorChange(Selection, bCancelArgument)
            If bCancelArgument Then
                Application.Undo
            End If
        End If            
        End If
    End If
    For Each oCell In ActiveWindow.VisibleRange.Cells
        oCell.ID = CStr(oCell.Interior.ColorIndex)
        sTempColorIndex = sTempColorIndex & oCell.ID
    Next oCell
    Set oPrevVisibleRange = ActiveWindow.VisibleRange
    sPrevVisibleRangeColorIndexes = sTempColorIndex

End Sub



[B][COLOR=#008000]'PSEUDO-EVENT EXAMPLE:
'====================[/COLOR][/B]

Private Sub OnCellColorChange(ByVal Target As Range, ByRef Cancel As Boolean)

    Dim oCell As Range
    Dim sPrompt As String, sPromptTitle As String
    
    For Each oCell In Target.Cells
        sPrompt = sPrompt & vbNewLine & RPad(oCell.Address, 20) & vbTab & _
        RPad(oCell.ID, 20) & vbTab & oCell.Interior.ColorIndex
    Next oCell
    
    sPromptTitle = RPad("Cell Addr", 20) & vbTab & _
    RPad("Prev Color Index", 20) & vbTab & "Cur Color Index"
    
    [COLOR=#008000]'Check immediate window for details.[/COLOR]
    Debug.Print sPromptTitle & vbNewLine & sPrompt
    
    If MsgBox("Color Change detected." & vbNewLine & "Proceed ?", vbYesNo, "Cell Color Change Pseudo-Event.") = vbNo Then
        [COLOR=#008000]'Set the Cancel arg to TRUE to undo the change in cells colors.[/COLOR]
        Cancel = True
    End If
End Sub

Using a windows timer is faster & would give more accurate results than reliying on the OnUpdate event of the commandbars but I think this code was fast enough when tested.