Sub FormatCells1()
Dim ws As Worksheet
Dim cell As Range
Dim formatInfo As String
Dim StartTime As Double
Dim EndTime As Double
StartTime = Timer
' Set the worksheet to the active sheet
Set ws = ActiveSheet
' Set the cell to the currently selected cell
Set cell = ActiveCell
' Loop until you encounter a blank cell
Do While Not IsEmpty(cell.Value)
' Call the FindAsteriskText function to get format info
formatInfo = FindAsteriskText(cell)
If formatInfo <> "No asterisk found in the cell." Then
' Extract the start position and length from the format info
Dim startPos As Long
Dim length As Long
startPos = Val(Mid(formatInfo, InStr(formatInfo, "Start position: ") + 15, InStr(formatInfo, ", Length:") - InStr(formatInfo, "Start position: ") - 15))
length = Val(Mid(formatInfo, InStr(formatInfo, "Length: ") + 8, InStr(formatInfo, ", End position:") - InStr(formatInfo, "Length: ") - 8))
' Apply specific formatting to the text within the start and length
With cell.Characters(1, length).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
'With cell.Characters(Start:=17, length:=10).Font
With cell.Characters(Start:=startPos, length:=endPos).Font
.Name = "AdvHC39a"
.FontStyle = "Regular"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End If
' Move to the next cell (one cell down)
Set cell = cell.Offset(1, 0)
Loop
' Message to announce the end of the run
EndTime = Timer
MsgBox "Formatting complete. End of the run."
MsgBox "Macro execution time: " & (EndTime - StartTime) & " seconds"
End Sub
Function FindAsteriskText(rng As Range) As String
Dim cellText As String
Dim startPos As Long
Dim endPos As Long
Dim length As Long
cellText = rng.Value
startPos = InStr(1, cellText, "*")
If startPos > 0 Then
endPos = InStr(startPos + 1, cellText, "*")
If endPos > 0 Then
length = endPos - startPos + 1
FindAsteriskText = "Start position: " & startPos & ", Length: " & length & ", End position: " & endPos
Else
FindAsteriskText = "Asterisk at the beginning but no closing asterisk found."
End If
Else
FindAsteriskText = "No asterisk found in the cell."
End If
End Function