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?

 

[Jaafar Tribak]

Small fix to prevent the code from erroring out when there is no UNDO list.

Change the CmndBars_OnUpdate routine above in the class module as follows :

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.Enabled Then
            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 If
    End With
    
End Sub

 

[sparky2205]

Hi folks,
I found a nice simple way to achieve this:

Private Sub Worksheet_SelectionChange(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.Font.Color <> Target.Offset(, 16).Font.Color Then
                If Target.Font.Color = 255 Then
                    With Target.Offset(, 16).Font
                      .Color = Target.Font.Color
                      .Italic = True
                    End With
                Else
                    With Target.Offset(, 16).Font
                      .Color = Target.Font.Color
                      .Italic = Target.Font.Italic
                    End With
                End If
            End If
    End If
    
End Sub

This is a mishmash of some of your ideas in this post, so I thank you for your time.
I'm afraid I didn't get time to test all your solutions in their entirety.

 

[Georgiboy]

I can see where the logic came from

 

[Jaafar Tribak]

I can see where the logic came from

Are you refering to the code I posted ?

 

[Georgiboy]

Are you refering to the code I posted ?

No @Jaafar Tribak, sorry I should have been clearer (I had had a few milkshakes yesterday), I was referring to post 12 following a similar logic to post 8.

Wish I had not posted at all to be honest and MrExcel does not allow the deletion of posts.

 

[Jaafar Tribak]

No @Jaafar Tribak, sorry I should have been clearer (I had had a few milkshakes yesterday), I was referring to post 12 following a similar logic to post 8.

Wish I had not posted at all to be honest and MrExcel does not allow the deletion of posts.

No worries my friend