Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Formating
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Formating
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Formating
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Formating
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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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) |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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) |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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) |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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) "Dallas" wrote in message ... 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) |
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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" wrote: 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) "Dallas" wrote in message ... 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) |
#12
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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) "Dallas" wrote in message ... 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" wrote: 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) "Dallas" wrote in message ... 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) |
#13
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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. "Rick Rothstein" wrote: 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) "Dallas" wrote in message ... 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" wrote: 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) "Dallas" wrote in message ... 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 |
#14
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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) "Dallas" wrote in message ... 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. "Rick Rothstein" wrote: 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) "Dallas" wrote in message ... 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. "Rick Rothstein" wrote: 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) "Dallas" wrote in message ... 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" wrote: 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) "Dallas" wrote in message ... 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 |
#15
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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. "Rick Rothstein" wrote: 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) "Dallas" wrote in message ... 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. "Rick Rothstein" wrote: 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) "Dallas" wrote in message ... 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. "Rick Rothstein" wrote: 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) "Dallas" wrote in message ... 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" wrote: 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) "Dallas" wrote in message ... 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 |
#16
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Replace a Spacific Character with Conditional Forma
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) "Dallas" wrote in message ... 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. "Rick Rothstein" wrote: 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) "Dallas" wrote in message ... 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. "Rick Rothstein" wrote: 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) "Dallas" wrote in message ... 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. "Rick Rothstein" wrote: 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) "Dallas" wrote in message ... 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" wrote: 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) "Dallas" wrote in message ... 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Character search and replace | Excel Worksheet Functions | |||
Date Formating and building character strings | Excel Discussion (Misc queries) | |||
Install dates formating using conditional formating? | Excel Discussion (Misc queries) | |||
Search and replace character with |
Excel Discussion (Misc queries) | |||
How to replace this character ... | Excel Programming |