VBA: Multiple Font Types/Colors in One Cell

[JKast]

Hi All,

I dabble in using VBA but am no pro by any means. I'm working with the code below, (which another user was kind enough to help me with), my issue develops when I try to format multiple fonts/colors into a single cell based on the character position within the cell. The code I'm having an issue with is highlighted in RED, hopefully it's something simple I'm overlooking. Thanks in advance for any help/hints!!

John

Sub TrimTeam1()
Dim myRng As Range, c As Range
Set myRng = Range("M5:DO67")
With myRng.Font
.FontStyle = "Regular"
.Size = 28
End With
For Each c In myRng
With c
Select Case .Value
Case Is = Chr(152): .Font.Name = "Wingdings 2"
.Font.Color = vbGreen
Case Is = Chr(187): .Font.Name = "Wingdings 2"
.Font.Color = vbGreen
Case Is = Chr(162): .Font.Name = "Wingdings"
.Font.Color = vbGreen
Case Is = Chr(88): .Font.Name = "Webdings"
.Font.Color = vbBlack
Case Is = Chr(112): .Font.Name = "Wingdings 3"
.Font.Color = vbBlue
Case Is = Chr(163): .Font.Name = "Wingdings 2"
.Font.Color = vbBlue
Case Is = Chr(174): .Font.Name = "Wingdings 2"
.Font.ColorIndex = 45
Case Is = Chr(76): .Font.Name = "Helviteca"
.Font.ColorIndex = 45
Case Is = Chr(85): .Font.Name = "Wingdings 2"
.Font.Color = vbBlack
Case Is = Chr(84): .Font.Name = "Wingdings 2"
.Font.Color = vbBlack
Case Is = Chr(204): .Font.Name = "Wingdings 2"
.Font.Color = vbBlack

Case Is = (Chr(187) & Chr(88)): .Characters(Start:=1, Length:=1).Font.Name = "Wingdings 2"
.Characters(Start:=2, Length:=1).Font.Name = "Webdings"
.Characters(Start:=1, Length:=1).Font.Color = vbGreen
.Characters(Start:=2, Length:=1).Font.Color = vbBlack

Case Is = (Chr(187) & Chr(204)): .Font.Name = "Wingdings 2"
.Characters(Start:=1, Length:=1).Font.Color = vbGreen
.Characters(Start:=2, Length:=1).Font.Color = vbBlack

Case Is = (Chr(162) & Chr(204)): .Characters(Start:=1, Length:=1).Font.Name = "Wingdings"
.Characters(Start:=2, Length:=1).Font.Name = "Wingdings 2"
.Characters(Start:=1, Length:=1).Font.Color = vbGreen
.Characters(Start:=2, Length:=1).Font.Color = vbBlack

Case Is = Chr(70): .Font.Name = "Wingdings 2"
.Font.ColorIndex = 15

Case Else: .Font.Name = "Times"
.Font.Color = vbRed
End Select
End With
Next c
End Sub

 

[JLGWhiz]

I don't know if this will help or not, but it is something I wrote for a novelty program and it could probably be adapted to do what you are trying to do. This randomizes the selection of Font, but the myValue variable could be given a static value of Wingdings or any other font. Font size also varies in the code, but could be made static. The colors could also be be managed to only show two intsead of multiple as now coded. But feel free to play with it or use what you want of it.

Code:
Sub WTThree() 'Displays each letter with different font and color horizontally on two lines
Dim MyValue As Integer, sh As Worksheet, counter As Long, fnt As Variant
Set sh = Worksheets("Sheet2")
MyString = "WATCHTHIS"
fnt = Array("Algerian", "Kristen ITC", "Comic Sans MS", "Forte", "Jokerman", "Colonna MT", "Book Antigua", "Broadway", "Chiller", "Playbill", "Georgia", "Mistral", "Bauhaus 93", "Eras Bold ITC")
counter = 1
Do
Randomize
MyValue = Int((13 * Rnd) + 1)
If counter <= 5 Then
sh.Cells(14, 3 + (counter * 2)).Font.Name = fnt(MyValue)
sh.Cells(14, 3 + (counter * 2)).Font.Size = (counter * 2) + 30
sh.Cells(14, 3 + (counter * 2)).Font.ColorIndex = (counter * 2) + 3
sh.Cells(14, 3 + (counter * 2)) = Mid(MyString, counter, 1)
End If
If counter >= 6 Then
sh.Cells(15, (counter * 2) - 6).Font.Name = fnt(MyValue)
sh.Cells(15, (counter * 2) - 6).Font.Size = (counter * 2) + 30
sh.Cells(15, (counter * 2) - 6).Font.ColorIndex = (counter * 2) + 5
sh.Cells(15, (counter * 2) - 6) = Mid(MyString, counter, 1)
End If
counter = counter + 1
'PlayExclam
HalfSecDly
Loop Until counter = 10
PauseTime
Set sh = Nothing
End Sub
Code:


Code"
Sub PauseTime()
Dim newHour As Integer, newMinute As Integer, newSecond As Integer, sitTime As Date
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 3
sitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait sitTime
End Sub
Code:

Code:
Public Function HalfSecDly()
Dim y As Double
y = Timer + 0.5
Do While Timer < y
DoEvents
Loop
End Function
Code:

 

[István Hirsch]

The macro which can introduce multiple font formats in a single cell is ready to use, visit: Find and replace, find and format excel VBA macro with regex - YouTube or Change font format in excel with VBA macro - YouTube

 

[István Hirsch]

Please watch the video how to perform this special task with the macro: Fonts of different format in the same cell - YouTube