Strikethrough Red and Underline Blue Macro

[Rainman76]

I have successfully written a Macro in Word to change the font color of
all text that has a strikethrough to red and all text that has an
underline I change the font to blue.

Can someone help me out with an Excel Macro like this? Keep in mind a
cell can contain text that has both underlined text and strikethrough
text within it.

 

[Guest]

Sub StrikeRedUnderBlue(ByVal Target As Range)

Dim CCell As Range, Char As Integer

For Each CCell In Target
With CCell
For Char = 1 To .Characters.Count
If .Characters(Char).Font.Strikethrough _
Then .Characters(Char).Font.Color = vbRed
If .Characters(Char).Font.Underline <> xlUnderlineStyleNone _
Then .Characters(Char).Font.Color = vbBlue
Next Char
End With
Next CCell

End Sub

 

[Peter T]

So what colour do you want if both strikethrough & underline. As you didn't
specify the following will colour font
- strikethrough to red
- underline to blue
- strikethrough + underline to violet
- not strickthrough & not underline to system black (automatic)

Start by selecting the cells you want processed

Sub test()
Dim X As Long
Dim cel As Range
Dim ch As Font
Dim vst, vun
For Each cel In Selection

X = 0
If FntFormat(cel.Font) = 0 Then
For i = 1 To Len(cel)
cel.Characters(i, 1).Font.ColorIndex = _
FntFormat(cel.Characters(i, 1).Font)
Next
Else
cel.ColorIndex = X
End If
Next
End Sub

Function FntFormat(fnt As Font) As Long
Dim v1, v2
Dim X As Long
v1 = fnt.Strikethrough
v2 = (fnt.Underline <> xlUnderlineStyleNone)
If IsNull(v1) Or IsNull(v2) Then
X = 0
Else
X = xlAutomatic
If v1 Then X = 3
If v2 Then
If X Then X = 13 Else X = 5
End If
End If
FntFormat = X
End Function

You message implied there might be mixed formats in the same cell, the above
should cater for that possibility. If not it's overkill.

Regards,
Peter T

 

[Peter T]

Ignore previous, somehow I pasted completely wrong code which was part draft
of the following, which I intended to post first time. These things happen!

Sub test()
Dim X As Long
Dim cel As Range
Dim ch As Font
Dim vst, vun
For Each cel In Selection

X = FntFormat(cel.Font)
If X = 0 Then
For i = 1 To Len(cel)
cel.Characters(i, 1).Font.ColorIndex = _
FntFormat(cel.Characters(i, 1).Font)
Next
Else
cel.Font.ColorIndex = X
End If
Next
End Sub

Function FntFormat(fnt As Font) As Long
Dim v1, v2
Dim X As Long
v1 = fnt.Strikethrough
v2 = (fnt.Underline <> xlUnderlineStyleNone)
If IsNull(v1) Or IsNull(v2) Then
X = 0
Else
X = xlAutomatic
If v1 Then X = 3
If v2 Then
If X > 0 Then X = 13 Else X = 5
End If
End If
FntFormat = X
End Function

Peter T

So what colour do you want if both strikethrough & underline. As you didn't
specify the following will colour font
- strikethrough to red
- underline to blue
- strikethrough + underline to violet
- not strickthrough & not underline to system black (automatic)

Start by selecting the cells you want processed

Sub test()
Dim X As Long
Dim cel As Range
Dim ch As Font
Dim vst, vun
For Each cel In Selection

X = 0
If FntFormat(cel.Font) = 0 Then
For i = 1 To Len(cel)
cel.Characters(i, 1).Font.ColorIndex = _
FntFormat(cel.Characters(i, 1).Font)
Next
Else
cel.ColorIndex = X
End If
Next
End Sub

Function FntFormat(fnt As Font) As Long
Dim v1, v2
Dim X As Long
v1 = fnt.Strikethrough
v2 = (fnt.Underline <> xlUnderlineStyleNone)
If IsNull(v1) Or IsNull(v2) Then
X = 0
Else
X = xlAutomatic
If v1 Then X = 3
If v2 Then
If X Then X = 13 Else X = 5
End If
End If
FntFormat = X
End Function

You message implied there might be mixed formats in the same cell, the above
should cater for that possibility. If not it's overkill.

Regards,
Peter T