Search and Replace a Spacific Character with Conditional Formating

[Dallas]

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

 

[Dallas]

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 _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

 

[Rick Rothstein]

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

 

[Dallas]

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.

 

[Dallas]

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!

 

[Dallas]

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]

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)

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

 

[Dallas]

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.

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 Rothstein]

Give this macro a try (I didn't test it, but I'm pretty sure it will
work)...

Sub SubstituteCharacters()
Dim X As Long
Dim R As Range
Dim Before As Variant
Dim After As Variant
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)
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
ElseIf .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
ElseIf .Text = "w" Then
.Font.Name = "Neuropol"
.Text = "V"
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
ElseIf .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
End Sub

 

[Dallas]

I tried somthing similar already but I went ahead and tried this one. The
first time I ran it it skipped over any cell that didnt' have a 6 in it so
ont the line that reads
If R.Value Like "*6*" Then
to
If R.Value Like "*" Then
When I ran the macro this time I had the same problem as before. It fixes
everything up to the cell that has the two symbols side by side in the same
font and changes both w and f characters to Neuropole font and w to V. Then
Excel Locks up and when I End Task in Windows Task Manager VBA pops up the
error "Unable to get the Font property of the Characters class" and proceeds
to highlight the line:
If .Font.Name = "UniversalMath1 BT" Then
When you look at the code it should work but it doesn't. I'm getting pretty
frustrated and I need a solution to this problem. Thank you for your
continued support.

 

[Rick Rothstein]

If R.Value Like "*6*" Then

Sorry, I forgot to modify the above line. Use the following line of code
instead of that one (leave the rest of my code as I originally posted it)...

If R.Value Like "*[6fw]*" Then

 

[Dallas]

That helps with the error and Excel locking up but still on that same cell
with the two symbols side by side It changed the entire cells font to
Neuropole and it displays two f's but the formula line only shows one. The
changed cell reads Vff.840 and the formula line reads Vf.840. Any sugestions

If R.Value Like "*6*" Then

Sorry, I forgot to modify the above line. Use the following line of code
instead of that one (leave the rest of my code as I originally posted it)...

If R.Value Like "*[6fw]*" Then

--
Rick (MVP - Excel)

I tried somthing similar already but I went ahead and tried this one. The
first time I ran it it skipped over any cell that didnt' have a 6 in it so
ont the line that reads
If R.Value Like "*6*" Then
to
If R.Value Like "*" Then
When I ran the macro this time I had the same problem as before. It fixes
everything up to the cell that has the two symbols side by side in the
same
font and changes both w and f characters to Neuropole font and w to V.
Then
Excel Locks up and when I End Task in Windows Task Manager VBA pops up the
error "Unable to get the Font property of the Characters class" and
proceeds
to highlight the line:
If .Font.Name = "UniversalMath1 BT" Then
When you look at the code it should work but it doesn't. I'm getting
pretty
frustrated and I need a solution to this problem. Thank you for your
continued support.

 

[Rick Rothstein]

I've looked over my code and I can't see why what you are describing is
happening. I will try to test the code, but I need some more data from you
first. I don't have all of the fonts installed that you are using, so I will
have to try and substitute ones I have for those I don't have. In order to
do this successfully, you need to tell me exactly what is in the cell you
wrote about BEFORE any code is run against it (I can't tell if the V in
Vf.840 was original or if that was a substituted character). So, show me the
exact text in the cell before anything changes it and, underneath that, show
me what each character's font name is (use a comma delimited list of font
names, one font name per character, in the same order as the listed
characters). Once you have done that, I'll reconstruct the text in the cell
using fonts I have and then see if I can duplicate the problem here; and, if
I can, hopefully modify the code to fix it.

--
Rick (MVP - Excel)

That helps with the error and Excel locking up but still on that same cell
with the two symbols side by side It changed the entire cells font to
Neuropole and it displays two f's but the formula line only shows one. The
changed cell reads Vff.840 and the formula line reads Vf.840. Any
sugestions

If R.Value Like "*6*" Then

Sorry, I forgot to modify the above line. Use the following line of code
instead of that one (leave the rest of my code as I originally posted
it)...

If R.Value Like "*[6fw]*" Then

--
Rick (MVP - Excel)

I tried somthing similar already but I went ahead and tried this one.
The
first time I ran it it skipped over any cell that didnt' have a 6 in it
so
ont the line that reads
If R.Value Like "*6*" Then
to
If R.Value Like "*" Then
When I ran the macro this time I had the same problem as before. It
fixes
everything up to the cell that has the two symbols side by side in the
same
font and changes both w and f characters to Neuropole font and w to V.
Then
Excel Locks up and when I End Task in Windows Task Manager VBA pops up
the
error "Unable to get the Font property of the Characters class" and
proceeds
to highlight the line:
If .Font.Name = "UniversalMath1 BT" Then
When you look at the code it should work but it doesn't. I'm getting
pretty
frustrated and I need a solution to this problem. Thank you for your
continued support.

:

Give this macro a try (I didn't test it, but I'm pretty sure it will
work)...

Sub SubstituteCharacters()
Dim X As Long
Dim R As Range
Dim Before As Variant
Dim After As Variant
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)
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
ElseIf .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
ElseIf .Text = "w" Then
.Font.Name = "Neuropol"
.Text = "V"
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
ElseIf .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
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.

:

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)


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

 

[Dallas]

Here is the original text
wf.840
(GDT,GDT,Arial,Arial,Arial,Arial)
Part of the problem is that as I mentioned on my first post I no longer have
these fonts either they were spacific to Autocad but when we got new
computers we didn't carry Autocad over to the new ones because our 3D sofware
has a DWG editor that does everything we were using the older version of
Autocad for. I have a font attached to the 3D modeling software but only 3 of
the company's computers are loaded with this software and all of the
computers need to be able to view the correct text. I really appreciate all
of your help. I won't get another chance to try anything until somtime
Monday. Thanks alot.

I've looked over my code and I can't see why what you are describing is
happening. I will try to test the code, but I need some more data from you
first. I don't have all of the fonts installed that you are using, so I will
have to try and substitute ones I have for those I don't have. In order to
do this successfully, you need to tell me exactly what is in the cell you
wrote about BEFORE any code is run against it (I can't tell if the V in
Vf.840 was original or if that was a substituted character). So, show me the
exact text in the cell before anything changes it and, underneath that, show
me what each character's font name is (use a comma delimited list of font
names, one font name per character, in the same order as the listed
characters). Once you have done that, I'll reconstruct the text in the cell
using fonts I have and then see if I can duplicate the problem here; and, if
I can, hopefully modify the code to fix it.

--
Rick (MVP - Excel)

That helps with the error and Excel locking up but still on that same cell
with the two symbols side by side It changed the entire cells font to
Neuropole and it displays two f's but the formula line only shows one. The
changed cell reads Vff.840 and the formula line reads Vf.840. Any
sugestions

If R.Value Like "*6*" Then

Sorry, I forgot to modify the above line. Use the following line of code
instead of that one (leave the rest of my code as I originally posted
it)...

If R.Value Like "*[6fw]*" Then

--
Rick (MVP - Excel)


I tried somthing similar already but I went ahead and tried this one.
The
first time I ran it it skipped over any cell that didnt' have a 6 in it
so
ont the line that reads
If R.Value Like "*6*" Then
to
If R.Value Like "*" Then
When I ran the macro this time I had the same problem as before. It
fixes
everything up to the cell that has the two symbols side by side in the
same
font and changes both w and f characters to Neuropole font and w to V.
Then
Excel Locks up and when I End Task in Windows Task Manager VBA pops up
the
error "Unable to get the Font property of the Characters class" and
proceeds
to highlight the line:
If .Font.Name = "UniversalMath1 BT" Then
When you look at the code it should work but it doesn't. I'm getting
pretty
frustrated and I need a solution to this problem. Thank you for your
continued support.

:

Give this macro a try (I didn't test it, but I'm pretty sure it will
work)...

Sub SubstituteCharacters()
Dim X As Long
Dim R As Range
Dim Before As Variant
Dim After As Variant
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)
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
ElseIf .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
ElseIf .Text = "w" Then
.Font.Name = "Neuropol"
.Text = "V"
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
ElseIf .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
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.

:

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)


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

 

[Rick Rothstein]

Okay, I tried out the code after switching the fonts and everything worked
as it was supposed to... no doubled up letters, no misapplied font
changes... in other words, I cannot duplicate the problem you are reporting.
Are you sure you are using the exact code I posted (with the mistakes
corrected) and not one of your modifications? Here is the code again, with
the corrections I fixed earlier; replace what you are now using with it and
tell me if you are still seeing the problem...

Sub SubstituteCharacters()
Dim X As Long
Dim R As Range
Dim Before As Variant
Dim After As Variant
For Each R In Worksheets("Sheet2").UsedRange
If R.Value Like "*[6fw]*" 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)
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
ElseIf .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
ElseIf .Text = "w" Then
.Font.Name = "Neuropol"
.Text = "V"
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
ElseIf .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
End Sub

--
Rick (MVP - Excel)

Here is the original text
wf.840
(GDT,GDT,Arial,Arial,Arial,Arial)
Part of the problem is that as I mentioned on my first post I no longer
have
these fonts either they were spacific to Autocad but when we got new
computers we didn't carry Autocad over to the new ones because our 3D
sofware
has a DWG editor that does everything we were using the older version of
Autocad for. I have a font attached to the 3D modeling software but only 3
of
the company's computers are loaded with this software and all of the
computers need to be able to view the correct text. I really appreciate
all
of your help. I won't get another chance to try anything until somtime
Monday. Thanks alot.

I've looked over my code and I can't see why what you are describing is
happening. I will try to test the code, but I need some more data from
you
first. I don't have all of the fonts installed that you are using, so I
will
have to try and substitute ones I have for those I don't have. In order
to
do this successfully, you need to tell me exactly what is in the cell you
wrote about BEFORE any code is run against it (I can't tell if the V in
Vf.840 was original or if that was a substituted character). So, show me
the
exact text in the cell before anything changes it and, underneath that,
show
me what each character's font name is (use a comma delimited list of font
names, one font name per character, in the same order as the listed
characters). Once you have done that, I'll reconstruct the text in the
cell
using fonts I have and then see if I can duplicate the problem here; and,
if
I can, hopefully modify the code to fix it.

--
Rick (MVP - Excel)

That helps with the error and Excel locking up but still on that same
cell
with the two symbols side by side It changed the entire cells font to
Neuropole and it displays two f's but the formula line only shows one.
The
changed cell reads Vff.840 and the formula line reads Vf.840. Any
sugestions
on this?
Again Thank You.

:

If R.Value Like "*6*" Then

Sorry, I forgot to modify the above line. Use the following line of
code
instead of that one (leave the rest of my code as I originally posted
it)...

If R.Value Like "*[6fw]*" Then

--
Rick (MVP - Excel)


I tried somthing similar already but I went ahead and tried this one.
The
first time I ran it it skipped over any cell that didnt' have a 6 in
it
so
ont the line that reads
If R.Value Like "*6*" Then
to
If R.Value Like "*" Then
When I ran the macro this time I had the same problem as before. It
fixes
everything up to the cell that has the two symbols side by side in
the
same
font and changes both w and f characters to Neuropole font and w to
V.
Then
Excel Locks up and when I End Task in Windows Task Manager VBA pops
up
the
error "Unable to get the Font property of the Characters class" and
proceeds
to highlight the line:
If .Font.Name = "UniversalMath1 BT" Then
When you look at the code it should work but it doesn't. I'm getting
pretty
frustrated and I need a solution to this problem. Thank you for your
continued support.

:

Give this macro a try (I didn't test it, but I'm pretty sure it
will
work)...

Sub SubstituteCharacters()
Dim X As Long
Dim R As Range
Dim Before As Variant
Dim After As Variant
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)
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
ElseIf .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
ElseIf .Text = "w" Then
.Font.Name = "Neuropol"
.Text = "V"
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
ElseIf .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
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.

:

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)


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

 

[Dallas]

I was repeatedly running these macros on the same file which I placed every
situation I knew that I needed the macro to fix. The workbook I was using
must have gotten corrupted during one of the crashes I experienced trying get
this macro to work. I copied your code over and tried it again and got the
same problem so I opened another file that had the same situation that was
giving me trouble and ran the macro and it ran perfectly. Hopfuly that is all
that it was. I will continue test this on other other files and hopfully I
won't have anymore trouble. Thank you for all of your help.

Okay, I tried out the code after switching the fonts and everything worked
as it was supposed to... no doubled up letters, no misapplied font
changes... in other words, I cannot duplicate the problem you are reporting.
Are you sure you are using the exact code I posted (with the mistakes
corrected) and not one of your modifications? Here is the code again, with
the corrections I fixed earlier; replace what you are now using with it and
tell me if you are still seeing the problem...

Sub SubstituteCharacters()
Dim X As Long
Dim R As Range
Dim Before As Variant
Dim After As Variant
For Each R In Worksheets("Sheet2").UsedRange
If R.Value Like "*[6fw]*" 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)
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
ElseIf .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
ElseIf .Text = "w" Then
.Font.Name = "Neuropol"
.Text = "V"
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
ElseIf .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
End Sub

--
Rick (MVP - Excel)

Here is the original text
wf.840
(GDT,GDT,Arial,Arial,Arial,Arial)
Part of the problem is that as I mentioned on my first post I no longer
have
these fonts either they were spacific to Autocad but when we got new
computers we didn't carry Autocad over to the new ones because our 3D
sofware
has a DWG editor that does everything we were using the older version of
Autocad for. I have a font attached to the 3D modeling software but only 3
of
the company's computers are loaded with this software and all of the
computers need to be able to view the correct text. I really appreciate
all
of your help. I won't get another chance to try anything until somtime
Monday. Thanks alot.

I've looked over my code and I can't see why what you are describing is
happening. I will try to test the code, but I need some more data from
you
first. I don't have all of the fonts installed that you are using, so I
will
have to try and substitute ones I have for those I don't have. In order
to
do this successfully, you need to tell me exactly what is in the cell you
wrote about BEFORE any code is run against it (I can't tell if the V in
Vf.840 was original or if that was a substituted character). So, show me
the
exact text in the cell before anything changes it and, underneath that,
show
me what each character's font name is (use a comma delimited list of font
names, one font name per character, in the same order as the listed
characters). Once you have done that, I'll reconstruct the text in the
cell
using fonts I have and then see if I can duplicate the problem here; and,
if
I can, hopefully modify the code to fix it.

--
Rick (MVP - Excel)


That helps with the error and Excel locking up but still on that same
cell
with the two symbols side by side It changed the entire cells font to
Neuropole and it displays two f's but the formula line only shows one.
The
changed cell reads Vff.840 and the formula line reads Vf.840. Any
sugestions
on this?
Again Thank You.

:

If R.Value Like "*6*" Then

Sorry, I forgot to modify the above line. Use the following line of
code
instead of that one (leave the rest of my code as I originally posted
it)...

If R.Value Like "*[6fw]*" Then

--
Rick (MVP - Excel)


I tried somthing similar already but I went ahead and tried this one.
The
first time I ran it it skipped over any cell that didnt' have a 6 in
it
so
ont the line that reads
If R.Value Like "*6*" Then
to
If R.Value Like "*" Then
When I ran the macro this time I had the same problem as before. It
fixes
everything up to the cell that has the two symbols side by side in
the
same
font and changes both w and f characters to Neuropole font and w to
V.
Then
Excel Locks up and when I End Task in Windows Task Manager VBA pops
up
the
error "Unable to get the Font property of the Characters class" and
proceeds
to highlight the line:
If .Font.Name = "UniversalMath1 BT" Then
When you look at the code it should work but it doesn't. I'm getting
pretty
frustrated and I need a solution to this problem. Thank you for your
continued support.

:

Give this macro a try (I didn't test it, but I'm pretty sure it
will
work)...

Sub SubstituteCharacters()
Dim X As Long
Dim R As Range
Dim Before As Variant
Dim After As Variant
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)
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
ElseIf .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
ElseIf .Text = "w" Then
.Font.Name = "Neuropol"
.Text = "V"
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
ElseIf .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
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.

:

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)


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

 

[Rick Rothstein]

It is no trouble, so don't worry about that. If it turns out you need me to
look into this further, just let me know.

--
Rick (MVP - Excel)

I was repeatedly running these macros on the same file which I placed every
situation I knew that I needed the macro to fix. The workbook I was using
must have gotten corrupted during one of the crashes I experienced trying
get
this macro to work. I copied your code over and tried it again and got the
same problem so I opened another file that had the same situation that was
giving me trouble and ran the macro and it ran perfectly. Hopfuly that is
all
that it was. I will continue test this on other other files and hopfully I
won't have anymore trouble. Thank you for all of your help.

Okay, I tried out the code after switching the fonts and everything
worked
as it was supposed to... no doubled up letters, no misapplied font
changes... in other words, I cannot duplicate the problem you are
reporting.
Are you sure you are using the exact code I posted (with the mistakes
corrected) and not one of your modifications? Here is the code again,
with
the corrections I fixed earlier; replace what you are now using with it
and
tell me if you are still seeing the problem...

Sub SubstituteCharacters()
Dim X As Long
Dim R As Range
Dim Before As Variant
Dim After As Variant
For Each R In Worksheets("Sheet2").UsedRange
If R.Value Like "*[6fw]*" 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)
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
ElseIf .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
ElseIf .Text = "w" Then
.Font.Name = "Neuropol"
.Text = "V"
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
ElseIf .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
End If
End If
End With
Next
End If
Next
End Sub

--
Rick (MVP - Excel)

Here is the original text
wf.840
(GDT,GDT,Arial,Arial,Arial,Arial)
Part of the problem is that as I mentioned on my first post I no longer
have
these fonts either they were spacific to Autocad but when we got new
computers we didn't carry Autocad over to the new ones because our 3D
sofware
has a DWG editor that does everything we were using the older version
of
Autocad for. I have a font attached to the 3D modeling software but
only 3
of
the company's computers are loaded with this software and all of the
computers need to be able to view the correct text. I really appreciate
all
of your help. I won't get another chance to try anything until somtime
Monday. Thanks alot.

:

I've looked over my code and I can't see why what you are describing
is
happening. I will try to test the code, but I need some more data from
you
first. I don't have all of the fonts installed that you are using, so
I
will
have to try and substitute ones I have for those I don't have. In
order
to
do this successfully, you need to tell me exactly what is in the cell
you
wrote about BEFORE any code is run against it (I can't tell if the V
in
Vf.840 was original or if that was a substituted character). So, show
me
the
exact text in the cell before anything changes it and, underneath
that,
show
me what each character's font name is (use a comma delimited list of
font
names, one font name per character, in the same order as the listed
characters). Once you have done that, I'll reconstruct the text in the
cell
using fonts I have and then see if I can duplicate the problem here;
and,
if
I can, hopefully modify the code to fix it.

--
Rick (MVP - Excel)


That helps with the error and Excel locking up but still on that
same
cell
with the two symbols side by side It changed the entire cells font
to
Neuropole and it displays two f's but the formula line only shows
one.
The
changed cell reads Vff.840 and the formula line reads Vf.840. Any
sugestions
on this?
Again Thank You.

:

If R.Value Like "*6*" Then

Sorry, I forgot to modify the above line. Use the following line of
code
instead of that one (leave the rest of my code as I originally
posted
it)...

If R.Value Like "*[6fw]*" Then

--
Rick (MVP - Excel)


I tried somthing similar already but I went ahead and tried this
one.
The
first time I ran it it skipped over any cell that didnt' have a 6
in
it
so
ont the line that reads
If R.Value Like "*6*" Then
to
If R.Value Like "*" Then
When I ran the macro this time I had the same problem as before.
It
fixes
everything up to the cell that has the two symbols side by side
in
the
same
font and changes both w and f characters to Neuropole font and w
to
V.
Then
Excel Locks up and when I End Task in Windows Task Manager VBA
pops
up
the
error "Unable to get the Font property of the Characters class"
and
proceeds
to highlight the line:
If .Font.Name = "UniversalMath1 BT" Then
When you look at the code it should work but it doesn't. I'm
getting
pretty
frustrated and I need a solution to this problem. Thank you for
your
continued support.

:

Give this macro a try (I didn't test it, but I'm pretty sure it
will
work)...

Sub SubstituteCharacters()
Dim X As Long
Dim R As Range
Dim Before As Variant
Dim After As Variant
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)
.Font.FontStyle = "Regular"
.Font.Size = 12
End If
ElseIf .Font.Name = "GDT" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
ElseIf .Text = "w" Then
.Font.Name = "Neuropol"
.Text = "V"
.Font.FontStyle = "Regular"
.Font.Size = 11
End If
ElseIf .Font.Name = "Symbol" Then
If .Text = "f" Then
.Font.Name = "Arial"
.Text = Chr(216)
.Font.FontStyle = "Regular"
.Font.Size = 10
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.

:

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)


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