I didn't go through your code in detail, but from what I gather you are
trying to do, I think this shorter macro will work for you...

Sub InsertPlusMinusSymbol()
Dim X As Long
Dim R As Range
For Each R In Worksheets("Sheet1").UsedRange
If R.Value Like "*6*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "UniversalMath1 BT" Then
If .Text = "6" Then
.Font.Name = "Calibri"
.Text = Chr(177) ' the plus/minus sign
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
End If
End With
Next
End If
Next
End Sub

--
Rick (MVP - Excel)


"Dallas" wrote in message
...
Sorry! When I copy and pasted my macro over to the post part of some of
the
lines of code got pushed to the next line. Here it is again.

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 = _
"UniversalMath! 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