I need a macro that will look through each character in each cell of a
worksheet and look for a spacific character with a spacific font and change
it to a different charater and a new font and size. I was using a couple of
symbol fonts that were attached to software that we did not carry over when
we upgraded to new computers. I borrowed a macro form another post and
modified it to meet what I needed but it only finds the first character match
of each cell then moves to the next cell. For example I need 16-3/461/8 to
read 16-3/4±1/8 where the first "6" in the original text has a font callout
of "Arial" and the second "6" has a font callout of "UniversalMath1 BT". Here
is a sample of the macro I am using. Please Help!

Option Explicit
Sub FixSymbols()

Dim myRng As Range
Dim FoundCell As Range
Dim FirstAddress As String
Dim myWords As Variant
Dim wCtr As Long
Dim wks As Worksheet
Dim StartPos As Long
Dim myValue As Variant
Dim Counter As Variant
Dim myNum As Variant

myValue = ActiveWorkbook.Sheets.Count
Dim ChkLastUntil()
Counter = 0
myNum = myValue
Do Until myNum = 0
myNum = myNum - 1
Counter = Counter + 1

Set wks = Worksheets(myValue - Counter + 1)

'change this to the list of words to find
myWords = Array("6")

With wks
'change this to the range that should be inspected
Set myRng = .Range("A1:M36")

With myRng
For wCtr = LBound(myWords) To UBound(myWords)
FirstAddress = ""

With .Cells
Set FoundCell = .Find(What:=myWords(wCtr), _
after:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If FoundCell Is Nothing Then
'do nothing, it wasn't found
MsgBox myWords(wCtr) & " wasn't found!"
Else
FirstAddress = FoundCell.Address
Do
StartPos = InStr(1, FoundCell.Value, _
myWords(wCtr),
vbTextCompare)
If StartPos = 0 Then
'this shouldn't happen,
'since the .find worked ok
Else
If FoundCell.Characters _
(Start:=StartPos, _

Length:=Len(myWords(wCtr))).Font _
.Name = "UniversalMath1 BT"
Then
With FoundCell.Characters _
(Start:=StartPos, _

Length:=Len(myWords(wCtr))).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 12
End With

With FoundCell.Characters _
(Start:=StartPos, _
Length:=Len(myWords(wCtr)))
.Text = "±"
End With

'look for the next one
Set FoundCell =
..FindNext(after:=FoundCell)

If FirstAddress =
FoundCell.Address Then
'at the first address
Exit Do
End If

Else 'look for the next one
Set FoundCell =
..FindNext(after:=FoundCell)
End If

If FirstAddress = FoundCell.Address
Then
'at the first address
Exit Do
End If
End If
Loop
End If
End With
Next wCtr
End With
End With

Loop
MsgBox "FixSymbols Done! "

End Sub