Run a macro when the font of a cell changes

[sparky2205]

Folks,
I have the following code:

Private Sub Worksheet_Change(ByVal Target As Range)
     
   Dim lr As Long
   lr = Cells(Rows.Count, 1).End(xlUp).Row
     
   If Not Intersect(Target, Range("$A$8:" & "A" & lr)) Is Nothing Then
      If Target(1).Font.Color = 0 Then
        With Target(1).Offset(0, 16).Font
          .Color = 0
          .Italic = False
        End With
      Else:
        With Target(1).Offset(0, 16).Font
          .Color = 255
          .Italic = True
        End With
      End If
   End If
   
End Sub

Snapshot:
I am updating the format of a number in column 16 based on the colour of the font in column 1. This works fine if I change the value in column 1.

What I'm looking for:
The same thing, but the macro must run when the font in column 1 is changed, not the value.

Is this possible?

 

[mumps]

I don't think that a change in font colour will trigger the Worksheet_Change event. You could use a helper cell which stores the rgb value of the font colour when you select the actual cell and refer to a change in the helper cell.

 

[sparky2205]

A change in font colour definitely does not trigger the Worksheet_Change event. That's where I'm having the issue.
I had tried your suggestion above but the issue with it is similar.
In a helper column (A) I put =FontColor(B8). This will update the RGB value of B8 when the font colour is changed. But only after I recalculate the formula in A8. I does not recalculate automatically.
I could do this in vba but what would trigger that code to fire? Again it would need to be when the font colour in B8 is changed. And I'm back to where I started.

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[Fluff]

There is no way for VBA to detect that the font colour of a cell has changed.

 

[Georgiboy]

Could you not store the colour value on a hidden sheet and use the Worksheet_SelectionChange event to check the stats of the active cell, if they are different from the stored value on the hidden sheet then you can fire an event and then update the information on the hidden sheet so it would fire the event again if you was to change it back?

 

[Georgiboy]

You would need to store the information about the active cell in a variable, when you exit the cell it would check the variable against the info held on the hidden sheet.

 

[Georgiboy]

Something like the below in Sheet1 module:

Dim rCell As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:A25")) Is Nothing Then
        On Error Resume Next
        If rCell.Font.ColorIndex <> Sheet2.Range(rCell.Address).Value Then
            MsgBox "Previous cell: " & rCell.Address & " colour was changed"
        End If
        On Error GoTo 0
        Set rCell = Target
        Sheet2.Range(Target.Address) = Target.Font.ColorIndex
    Else
        If rCell.Font.ColorIndex <> Sheet2.Range(rCell.Address).Value Then
            MsgBox "Previous cell: " & rCell.Address & " colour was changed"
            Set rCell = Nothing
        End If
    End If
End Sub

Example file below:
Sparky.xlsm

 

[sparky2205]

Folks,
thanks for all the input. Just wanted to let you know that I'm working through the suggestions and I will get back to you as soon as I've decided on the best solution for my situation.
Enjoy your weekend.

 

[Jaafar Tribak]

You can mimic a font color change event with some trickery ... Not a perfect workaround but it should help.

Add a new class module to you vbaproject and give the class module the name of CFontColorChanged

1- Place this code in the newly added Class Module:

Option Explicit

Event FontColorChanged( _
    ByVal Target As Range, _
    ByVal PreviousColor As Long, _
    ByVal CurrentColor As Long, _
    ByRef Cancel As Boolean _
)

Private WithEvents CmndBars As CommandBars

Private Sub Class_Initialize()
    Set CmndBars = Application.CommandBars
    Call CmndBars_OnUpdate
End Sub

Private Sub CmndBars_OnUpdate()

    Static lPrevColor As Long
    Static lPrevListCount As Long
    Dim oCtrl As CommandBarControl
    Dim bCancel As Boolean
 
    Set oCtrl = Application.CommandBars.FindControl(ID:=128&)
 
    With ActiveWindow
        If oCtrl.List(1&) = "Font" Then
            If lPrevListCount <> oCtrl.ListCount Then
                If lPrevColor <> .RangeSelection.Font.Color Then
                    RaiseEvent FontColorChanged(.RangeSelection, lPrevColor, .RangeSelection.Font.Color, bCancel)
                    If bCancel Then
                        Application.Undo
                    End If
                End If
            End If
        End If
        If Not IsNull(.RangeSelection.Font.Color) Then
            lPrevColor = .RangeSelection.Font.Color
            lPrevListCount = oCtrl.ListCount
        End If
    End With
 
End Sub

2- Place the following code in the ThisWorkbook Module for sinking and implementing the color change event :

Option Explicit

Private WithEvents oCFont As CFontColorChanged

Private Sub Workbook_Open()
    Set oCFont = New CFontColorChanged
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If oCFont Is Nothing Then
        Set oCFont = New CFontColorChanged
    End If
End Sub

'____________________________________ Font Color Change Event ______________________________________

Private Sub oCFont_FontColorChanged( _
    ByVal Target As Range, _
    ByVal PreviousColor As Long, _
    ByVal CurrentColor As Long, _
    Cancel As Boolean _
)

    Dim sMsg As String, sTitle As String
 
    sMsg = "You changed the Font color of Cell(s):   "
    sMsg = sMsg & "(" & Target.Address & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "From Color : [" & PreviousColor & "] "
    sMsg = sMsg & "To Color : [" & CurrentColor & "]" & vbNewLine
    sMsg = sMsg & vbNewLine
    sMsg = sMsg & "Do you want to 'UNDO'" & vbNewLine & "this last Font color change?"
 
    sTitle = "Font Changed Event."
 
    If MsgBox(sMsg, vbYesNo + vbInformation, sTitle) = vbYes Then
        Cancel = True
    End If

End Sub

Edit:
Note that this code is probably language dependent as it uses the captions in the Undo list .