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

3 Replies

Copper Contributor

Jun 08, 2023

Having some trouble with the VBA code.

First, how should I set the Range to be a workbook, or the active sheet?

Second, the VBA code doesn't seem to distinguish or modify fonts at all. Pasting characters into the code strips font information, and running the code will only alter some characters, and not change the font, so I'd still have to do a search replace font sweep after running the macro. Ideally that wouldn't be necessary.

NikolinoDE

Platinum Contributor

Jun 09, 2023

Benkyo

To set the range to be a workbook or the active sheet, you can modify the code as follows:

To set the range as the entire workbook, you can use the following code:

Set rng = ThisWorkbook.Sheets("Sheet1").UsedRange

Replace "Sheet1" with the name of your sheet.

To set the range as the active sheet, you can use the following code:

Set rng = ActiveSheet.UsedRange

Regarding the font issue, replacing characters with specific fonts in Excel using VBA can be a bit tricky. The font information is associated with the cell formatting, and directly modifying the font of individual characters within a cell is not easily achievable with built-in Excel functions.

However, there is a workaround you can try. Instead of replacing the characters with their corresponding symbols in the same cell, you can copy the modified text to a separate column where you set the font to the desired symbol font. Here's an updated version of the code that implements this approach:

Sub ReplaceCharactersWithSymbols()
    Dim rng As Range
    Dim cell As Range
    Dim originalText As String
    Dim modifiedText As String
    Dim targetRange As Range
    
    ' Set the range where your data is located
    Set rng = ThisWorkbook.Sheets("Sheet1").UsedRange ' Update the sheet name as per your data
    
    ' Set the range where the modified text will be placed
    Set targetRange = ThisWorkbook.Sheets("Sheet1").Range("B1:B100") ' Update the sheet name and range as per your data
    
    ' Loop through each cell in the range
    For Each cell In rng
        ' Get the original text from the cell
        originalText = cell.Value
        modifiedText = originalText
        
        ' Replace the characters with their corresponding symbols
        modifiedText = Replace(modifiedText, "°", "°")
        modifiedText = Replace(modifiedText, "×", "×")
        modifiedText = Replace(modifiedText, "μ", "μ")
        ' Add more Replace statements for each character you want to replace
        
        ' Copy the modified text to the target range and set the font to the desired symbol font
        targetRange.Value = modifiedText
        targetRange.Font.Name = "Symbol" ' Replace with the desired symbol font
        
        ' Move the target range down to the next row
        Set targetRange = targetRange.Offset(1)
    Next cell
End Sub

Code is untested

In this updated code, the modified text is copied to a separate column (targetRange) in the same sheet, and the font of the targetRange is set to the desired symbol font. This way, the modified text will be displayed in the desired font.

Make sure to update the sheet names, ranges, and add more Replace statements as needed for your specific characters.

Again, please note that the direct modification of fonts for individual characters within a cell is not a straightforward task in Excel, and this workaround can help achieve a similar result by copying the modified text to a separate column with the desired font.

Benkyo

Copper Contributor

Jun 10, 2023

Thanks for all the help!

I didn't want to use that workaround, I also sought help from a tech-adjacent community, and I eventually came up with something that does everything I want done. For anyone else that might stumble across this thread who wants to make a similar VBA macro, the following code should be easy enough to use. Just substitute your target font name and symbols/unicode as required.

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

Forum Discussion

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

3 Replies

Resources