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

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

I _think_ that this does what you want.

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 CurPos As Long

myWords = Array("6")

For Each wks In ActiveWorkbook.Worksheets
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
CurPos = 1
Do
StartPos = InStr(CurPos, FoundCell.Value, _
myWords(wCtr), _
vbTextCompare)
If StartPos = 0 Then
Exit Do
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
End If
End If
CurPos = StartPos + 1
Loop

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

'since you're changing the character
'it may not be found at the end
If FoundCell Is Nothing Then
Exit Do
End If

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

MsgBox "FixSymbols Done!"

End Sub


Dallas wrote:

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

--

Dave Peterson

Dave: Thank you for the post! Your codedid't work at first but I had a little
more time to look at it today and I noticed an exclamation mark in place of
the "1" in the font name that was being looked for. Once I fixed that the
Macro worked perfectly.
Thanks alot; it is very much appreciated.

"Dave Peterson" wrote:

I _think_ that this does what you want.

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 CurPos As Long

myWords = Array("6")

For Each wks In ActiveWorkbook.Worksheets
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
CurPos = 1
Do
StartPos = InStr(CurPos, FoundCell.Value, _
myWords(wCtr), _
vbTextCompare)
If StartPos = 0 Then
Exit Do
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
End If
End If
CurPos = StartPos + 1
Loop

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

'since you're changing the character
'it may not be found at the end
If FoundCell Is Nothing Then
Exit Do
End If

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

MsgBox "FixSymbols Done!"

End Sub


Dallas wrote:

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

--

Dave Peterson

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

Rick: Thank You! I have to admit I am very new macros and VBA programming.
All of my programming experience is with CNC machine G-code which is an
entirely different beast. I had to change the sheet callout to refernce by
index number to get it to work because the sheets in my workbooks have custom
names. I then added a count and loop sequence to cycle through all of the
sheets in the workbook and it worked beautifully. I thought that there was a
way to make the code shorter and simpler, I just wasn't sure how. Very much
appreciated, thank you!

"Rick Rothstein" wrote:

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

Some more Help Please! I guess I should have mentioned before that I have
other symbols I neet to fix as well. The problem seems to be when I have two
symbols next to each other in the same font. When I run a variation of your
macro It changes the font on both of them and then excel locks up. The error
that I get is
"Unable to get the Font property of the Character class". The cell that the
error occurs on reads wf.840 where the w represents a countersink symbol in
font "GDT"
and "f" represents a diameter symbol in the same font. The rest of the
characters in the cell are in the "Arial" font. I need to Change the "w" to a
capital "V" in the "Neuropol" and the "f" to the diameter symbol or Chr(216)
in th "Arial". I als need the macro to look for "f" in the "Symbol" font and
change it to the the diameter symbol. When I use Dave's macro it runs without
errors but if I search for the "f" first on the same cell it changes the font
on both the "f" and the "w" to "Arial" and if I search for the "w" first it
changes the font of the whole cell to "Neuropol". I would like to change
everything in one macro but seperate macros for each is fine too; I will run
a sepeate macro to cycle through them if I have too.
Please give me what ever suggestions you might have. Thank You.

p.s. Here is the modified code. I tried alot variations to make one macro
for everything but finally ended with this, seperate macros for each.

Sub FixPlusMinusSymbol()
Dim X As Long
Dim R As Range
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
For Each R In Worksheets(myValue - Counter + 1).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
Loop
MsgBox "FixPlusMinus Done!"
End Sub
Sub FixDiameterSymbol1()
Dim X As Long
Dim R As Range
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
For Each R In Worksheets(myValue - Counter + 1).UsedRange
If R.Value Like "*f*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216) ' the diameter sign
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
Loop
MsgBox "FixDiameter1 Done!"
End Sub
Sub FixDiameterSymbol2()
Dim X As Long
Dim R As Range
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
For Each R In Worksheets(myValue - Counter + 1).UsedRange
If R.Value Like "*f*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216) ' the diameter sign
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
Loop
MsgBox "FixDiameter2 Done!"
End Sub
Sub FixCountersinkSymbol()
Dim X As Long
Dim R As Range
Dim myValue As Variant
Dim Counter As Variant
Dim myNum As Variant

ActiveWorkbook.Sheets(1).Activate
myValue = ActiveWorkbook.Sheets.Count
Dim ChkLastUntil()
Counter = 0
myNum = myValue
Do Until myNum = 0
myNum = myNum - 1
Counter = Counter + 1
For Each R In Worksheets(myValue - Counter + 1).UsedRange
If R.Value Like "*w*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "GDT" Then
If .Text = "w" Then
.Font.Name = "Neuropol"
.Text = Chr(86) ' the countersink sign
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
End If
End With
Next
End If
Next
Loop
MsgBox "FixCountersink Done!"
End Sub


"Rick Rothstein" wrote:

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)

Can you clarify the FROM and TO font names and symbols... your text
description and your code appear to be different. List them across in this
order for us (one conversion per line) please...

"From Font Name" "From Character" "To Font Name" "To Character" "To Size"

--
Rick (MVP - Excel)


"Dallas" wrote in message
...
Some more Help Please! I guess I should have mentioned before that I have
other symbols I neet to fix as well. The problem seems to be when I have
two
symbols next to each other in the same font. When I run a variation of
your
macro It changes the font on both of them and then excel locks up. The
error
that I get is
"Unable to get the Font property of the Character class". The cell that
the
error occurs on reads wf.840 where the w represents a countersink symbol
in
font "GDT"
and "f" represents a diameter symbol in the same font. The rest of the
characters in the cell are in the "Arial" font. I need to Change the "w"
to a
capital "V" in the "Neuropol" and the "f" to the diameter symbol or
Chr(216)
in th "Arial". I als need the macro to look for "f" in the "Symbol" font
and
change it to the the diameter symbol. When I use Dave's macro it runs
without
errors but if I search for the "f" first on the same cell it changes the
font
on both the "f" and the "w" to "Arial" and if I search for the "w" first
it
changes the font of the whole cell to "Neuropol". I would like to change
everything in one macro but seperate macros for each is fine too; I will
run
a sepeate macro to cycle through them if I have too.
Please give me what ever suggestions you might have. Thank You.

p.s. Here is the modified code. I tried alot variations to make one macro
for everything but finally ended with this, seperate macros for each.

Sub FixPlusMinusSymbol()
Dim X As Long
Dim R As Range
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
For Each R In Worksheets(myValue - Counter + 1).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
Loop
MsgBox "FixPlusMinus Done!"
End Sub
Sub FixDiameterSymbol1()
Dim X As Long
Dim R As Range
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
For Each R In Worksheets(myValue - Counter + 1).UsedRange
If R.Value Like "*f*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216) ' the diameter sign
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
Loop
MsgBox "FixDiameter1 Done!"
End Sub
Sub FixDiameterSymbol2()
Dim X As Long
Dim R As Range
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
For Each R In Worksheets(myValue - Counter + 1).UsedRange
If R.Value Like "*f*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216) ' the diameter sign
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
Loop
MsgBox "FixDiameter2 Done!"
End Sub
Sub FixCountersinkSymbol()
Dim X As Long
Dim R As Range
Dim myValue As Variant
Dim Counter As Variant
Dim myNum As Variant

ActiveWorkbook.Sheets(1).Activate
myValue = ActiveWorkbook.Sheets.Count
Dim ChkLastUntil()
Counter = 0
myNum = myValue
Do Until myNum = 0
myNum = myNum - 1
Counter = Counter + 1
For Each R In Worksheets(myValue - Counter + 1).UsedRange
If R.Value Like "*w*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "GDT" Then
If .Text = "w" Then
.Font.Name = "Neuropol"
.Text = Chr(86) ' the countersink sign
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
End If
End With
Next
End If
Next
Loop
MsgBox "FixCountersink Done!"
End Sub


"Rick Rothstein" wrote:

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)

Sorry for the confusion. Here is what I need changed.

"UniversalMath1 BT" "6" to "Calibri" "Chr(177)" "12"

"GDT" "f" to "Arial" "Chr(216)" "10"

"Symbol" "f" to "Arial" "Chr(216)" "10"

"GDT" "w" to "Neuropol" "Chr(86)" "11"

Thanks again for your help.

"Rick Rothstein" wrote:

Can you clarify the FROM and TO font names and symbols... your text
description and your code appear to be different. List them across in this
order for us (one conversion per line) please...

"From Font Name" "From Character" "To Font Name" "To Character" "To Size"

--
Rick (MVP - Excel)


"Dallas" wrote in message
...
Some more Help Please! I guess I should have mentioned before that I have
other symbols I neet to fix as well. The problem seems to be when I have
two
symbols next to each other in the same font. When I run a variation of
your
macro It changes the font on both of them and then excel locks up. The
error
that I get is
"Unable to get the Font property of the Character class". The cell that
the
error occurs on reads wf.840 where the w represents a countersink symbol
in
font "GDT"
and "f" represents a diameter symbol in the same font. The rest of the
characters in the cell are in the "Arial" font. I need to Change the "w"
to a
capital "V" in the "Neuropol" and the "f" to the diameter symbol or
Chr(216)
in th "Arial". I als need the macro to look for "f" in the "Symbol" font
and
change it to the the diameter symbol. When I use Dave's macro it runs
without
errors but if I search for the "f" first on the same cell it changes the
font
on both the "f" and the "w" to "Arial" and if I search for the "w" first
it
changes the font of the whole cell to "Neuropol". I would like to change
everything in one macro but seperate macros for each is fine too; I will
run
a sepeate macro to cycle through them if I have too.
Please give me what ever suggestions you might have. Thank You.

p.s. Here is the modified code. I tried alot variations to make one macro
for everything but finally ended with this, seperate macros for each.

Sub FixPlusMinusSymbol()
Dim X As Long
Dim R As Range
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
For Each R In Worksheets(myValue - Counter + 1).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
Loop
MsgBox "FixPlusMinus Done!"
End Sub
Sub FixDiameterSymbol1()
Dim X As Long
Dim R As Range
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
For Each R In Worksheets(myValue - Counter + 1).UsedRange
If R.Value Like "*f*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216) ' the diameter sign
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
Loop
MsgBox "FixDiameter1 Done!"
End Sub
Sub FixDiameterSymbol2()
Dim X As Long
Dim R As Range
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
For Each R In Worksheets(myValue - Counter + 1).UsedRange
If R.Value Like "*f*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216) ' the diameter sign
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
Loop
MsgBox "FixDiameter2 Done!"
End Sub
Sub FixCountersinkSymbol()
Dim X As Long
Dim R As Range
Dim myValue As Variant
Dim Counter As Variant
Dim myNum As Variant

ActiveWorkbook.Sheets(1).Activate
myValue = ActiveWorkbook.Sheets.Count
Dim ChkLastUntil()
Counter = 0
myNum = myValue
Do Until myNum = 0
myNum = myNum - 1
Counter = Counter + 1
For Each R In Worksheets(myValue - Counter + 1).UsedRange
If R.Value Like "*w*" Then
For X = 1 To Len(R.Value)
With R.Characters(X, 1)
If .Font.Name = "GDT" Then
If .Text = "w" Then
.Font.Name = "Neuropol"
.Text = Chr(86) ' the countersink sign
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
End If
End With
Next
End If
Next
Loop
MsgBox "FixCountersink Done!"
End Sub


"Rick Rothstein" wrote:

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)