Looking for a way to substitute all non-alphanumeric characters with specific font

Thanks for all the help!

For anyone that might stumble across this thread in the future wanting to do the same thing (replace specific characters with another font), here's what I finally came up. Tested and works well.

Sub SymbolSubstitution()

    Dim rng1, rng2, rng3 As Range
    Dim newText As String
        
    Application.ScreenUpdating = False
        
    ' Find range to search over.
    Set rng1 = Cells.Find("*", [a1], xlFormulas, xlPart, xlByRows, xlPrevious)
    Set rng2 = Cells.Find("*", [a1], xlFormulas, xlPart, xlByColumns, xlPrevious)
    If Not rng1 Is Nothing Then
        Set rng3 = Range([a1], Cells(rng1.Row, rng2.Column))
    Else
        MsgBox "Worksheet is empty", vbExclamation, "Error"
        Exit Sub
    End If
        
    ' Loop over cells in range.
    For Each cell In rng3
        ' Only check non-empty cells.
        If cell.Value <> "" Then


            Call ConvertToSymbolAndReplace(cell, "Δ", "D")
            Call ConvertToSymbolAndReplace(cell, "Φ", "F")
            Call ConvertToSymbolAndReplace(cell, "Ω", "W")
            Call ConvertToSymbolAndReplace(cell, "α", "a")
            Call ConvertToSymbolAndReplace(cell, "β", "b")
            Call ConvertToSymbolAndReplace(cell, "χ", "c")
            Call ConvertToSymbolAndReplace(cell, "δ", "d")
            Call ConvertToSymbolAndReplace(cell, "ε", "e")
            Call ConvertToSymbolAndReplace(cell, "η", "h")
            Call ConvertToSymbolAndReplace(cell, "φ", "j")
            Call ConvertToSymbolAndReplace(cell, "λ", "l")
            Call ConvertToSymbolAndReplace(cell, "μ", "m")
            Call ConvertToSymbolAndReplace(cell, "π", "p")
            Call ConvertToSymbolAndReplace(cell, "θ", "q")
            Call ConvertToSymbolAndReplace(cell, "×", "´")
            Call ConvertToSymbol(cell, "~")
            Call ConvertToSymbol(cell, "&")
            Call ConvertToSymbol(cell, "+")
            Call ConvertToSymbol(cell, "%")
            Call ConvertToSymbol(cell, "<")
            Call ConvertToSymbol(cell, "=")
            Call ConvertToSymbol(cell, ">")
            Call ConvertToSymbol(cell, "°")
            Call ConvertToSymbol(cell, "±")
            Call ConvertToSymbolAndReplaceUnicode(cell, &H2219, &HD7) ' Bullet (must run after × to ´)
            Call ConvertToSymbolAndReplaceUnicode(cell, &H2211, &H53) ' Sum/sigma sign
            Call ConvertToSymbolAndReplaceUnicode(cell, &H2212, &H2D) ' Minus sign
            Call ConvertToSymbolAndReplaceUnicode(cell, &H2264, &HA3) ' Less than or equal sign
            Call ConvertToSymbolAndReplaceUnicode(cell, &H2265, &HB3) ' Greater than or equal sign
            Call ConvertToSymbolAndReplaceUnicode(cell, &H221A, &HD6) ' Square root sign
            Call ConvertToSymbolAndReplaceUnicode(cell, &H221E, &HA5) ' Infinity sign
            Call ConvertToSymbolAndReplaceUnicode(cell, &H222B, &HF2) ' Integral sign
            Call ConvertToSymbolAndReplaceUnicode(cell, &H2206, &H44) ' Alternative Delta sign
            Call ConvertToSymbolAndReplaceUnicode(cell, &H192, &HA6) ' Function sign

        End If
    Next cell
       
    Application.ScreenUpdating = True

End Sub

Sub ConvertToSymbolAndReplace(ByRef thisCell As Variant, ByVal inputChar As String, ByVal outputChar As String)

    Dim charPos As Long
    
    charPos = InStr(thisCell.Value, inputChar)
    
    Do While charPos > 0
        thisCell.Characters(charPos, 1).Text = outputChar
        thisCell.Characters(charPos, 1).Font.Name = "Symbol"
        charPos = InStr(charPos + 1, thisCell.Value, inputChar)
    Loop
    
End Sub

Sub ConvertToSymbol(ByRef thisCell As Variant, ByVal inputChar As String)

    Dim charPos As Long
    charPos = InStr(thisCell.Value, inputChar)
    
    Do While charPos > 0
        thisCell.Characters(charPos, 1).Font.Name = "Symbol"
        charPos = InStr(charPos + 1, thisCell.Value, inputChar)
    Loop

End Sub

Sub ConvertToSymbolAndReplaceUnicode(ByRef thisCell As Variant, ByVal inputCharCode As Long, ByVal outputCharCode As Long)

    Dim charPos As Long
    charPos = InStr(thisCell.Value, ChrW(inputCharCode))
    
    Do While charPos > 0
        thisCell.Characters(charPos, 1).Text = ChrW(outputCharCode)
        thisCell.Characters(charPos, 1).Font.Name = "Symbol"
        charPos = InStr(charPos + 1, thisCell.Value, ChrW(inputCharCode))
    Loop

End Sub