Finding matches from a list and replacing from another list, one by one (not global)

I need to create a pair of macros, one to replace specified characters in font A with the corresponding characters in font B, and one to do the same thing the other way around.

-----------
MACRO #1 (FindSymbolReplaceNormal)


This macro should find a specified character in the Symbol font and replace it with the corresponding character in the normal font.


For example, the following code will find all occurrences of the degree symbol in the Symbol font and replace them with the degree symbol in the normal font.

Code:

---

Sub FindSymbolReplaceNormal()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ChrW(61616)
        .Replacement.Text = "°"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
EndSub

---

-----------
MACRO #2 (FindNormalReplaceSymbol)


This macro should find a specified character in the normal font and replace it with the corresponding character in the Symbol font.


For example, the following code will find all occurrences of the degree symbol in the normal font and replace them with the degree symbol in the Symbol font.

Code:

---

Sub FindNormalReplaceSymbol()
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "°"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
    End With
    Selection.Find.Execute
    Selection.InsertSymbol Font:="Symbol", CharacterNumber:=-3920, Unicode:=True
End Sub

---

-----------
Note that finding a character in the Symbol font and replacing it with the corresponding character in the normal font can be done with a direct find/replace function (as in Macro #1), but finding a character in the normal font and replacing it with the corresponding character in the Symbol font cannot be done with a direct find/replace function but needs to be done by first finding the character in the normal font and then using the InsertSymbol function to overwrite it (not simply replace it) with the required character (as in Macro #2).


I would like to make both macros work as follows.


- Each macro should run through a whole document (or a selected block of text) to find and replace all matches, but it should stop on each match and give the user the option of replacing or skipping each one individually, not globally.


- Each macro should specify a list of characters to find, and a corresponding list of characters to replace. The macro should loop through the "find" list and replace matches with the corresponding character from the "replace" list. For example, Macro 1 should find the degree symbol and the plus-or-minus symbol in the Symbol font -- i.e., ChrW(61616) and ChrW(61617) -- and replace them with the corresponding characters in the normal font -- i.e., "°" and "±" respectively; and Macro 2 should do the reverse, but using the InsertSymbol function to overwrite rather than simply replace.


Is this possible?

The following will do that:

Code:

---

Sub Macro1()
Dim vFindText As Variant
Dim vReplaceText As Variant
Dim oRng As Range
Dim i As Integer
    vFindText = Array(ChrW(61616), ChrW(61617))
    vReplaceText = Array(Chr(176), Chr(177))
    For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            .Font.Name = "Symbol"
            Do While .Execute
                oRng.Text = vReplaceText(i)
                oRng.Style = "Normal"
                oRng.Collapse 0
            Loop
        End With
    Next i
End Sub

Sub Macro2()
Dim vFindText As Variant
Dim vReplaceText As Variant
Dim oRng As Range
Dim i As Integer
    vFindText = Array(Chr(176), Chr(177))
    vReplaceText = Array(ChrW(61616), ChrW(61617))
    For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            .Font.Name = "Symbol"
            Do While .Execute
                oRng.Text = vReplaceText(i)
                oRng.Style = "Normal"
                oRng.Collapse 0
            Loop
        End With
    Next i
End Sub

---

You can add any other symbols and their corresponding values into the arrays as required.

Thanks for your reply. I tried those macros in the test document below, and they appeared to run OK, but nothing appeared to be changed.

Attachment 30498

I note the two macros are identical except that the two lines defining the find and replace arrays are reversed.

- Macro #1 needs to change found characters from Symbol to normal font, but Macro #2 needs to change found characters from normal to Symbol font. Will this code do that?

- Both macros need to stop on each match and give the user the option of replacing or skipping each one individually, not globally. Will this code do that?

How will you know in what section the find and replace would occur?

I'm not sure I understand what you are asking. Each macro should find and replace all matches in a selected block of text (or the whole document if nothing is selected), but it should stop on each match and give the user the option of replacing or skipping each one individually, not globally.

How would you know which one it has found and is asking if you want to replace it?

In these examples, I envisage the macro would loop through the selection (or the whole document if nothing is selected) twice: on the first loop, it would search for the degree symbol and stop on each match with some kind of prompt (e.g., Replace? [Yes] [No]), then on the second loop it would search for the plus-or-minus symbol and stop on each match with the same prompt. Each time it stops on a match, the user can see the found character, highlighted in the usual way when the find function is used.

Harry88, you are skipping over my question yet again. Posts 5 & 7 are descriptors of the intent of the macros, so we don't need to hear your broad definitions of them again for we understood that from Post#1. What I am trying to determine here is, once the macros find a ° Symbol or the - or - symbol, how do you determine where it is in the document, so that you can decide do I replace it or not? What logic do you intend to apply to come up with the decision to replace or not?

Talking about Post #1. You mention a number of times the descriptor "replace" or "replacing" yet later on mention you want to overwrite rather than replace. What is your understanding of overwrite compared to replace?

Sorry I misunderstood what you were asking.

Re the location of each match and deciding whether to replace or skip it: The decision is an editorial one. It depends on the context of the character; e.g., symbols within the text are usually replaced, but symbols within equation objects are usually skipped. The location within the document is not relevant. The replacement should not be done globally, hence the requirement to stop on each match so the user can replace or skip each one individually.

Re "replace" vs "overwrite": Fot Macro #1, which needs to replace characters in the Symbol font with ones in the normal font, a regular "replace" operation can be used; e.g., ChrW(61616) can be replaced with "°". For Macro #2, which needs to replace characters in the normal font with ones in the Symbol font, the output should be the same as the result of using the InsertSymbol function, and I don't know whether a regular "replace" operation can achieve this – e.g., simply replace "°" with ChrW(61616) – or whether the InsertSymbol function needs to be used. I have previously experienced compatibility issues with characters in the Symbol font that are not inserted in this way.

The following should work and appears to do so with your sample

Code:

---

Sub Macro1()
Dim vFindText As Variant
Dim vReplaceText As Variant
Dim oRng As Range
Dim i As Integer
Dim lAsk As Long
    vFindText = Array(ChrW(61616), ChrW(61617))
    vReplaceText = Array(Chr(176), Chr(177))
    For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            Do While .Execute
                oRng.Select
                lAsk = MsgBox("Replace Symbol", vbYesNoCancel)
                If lAsk = 2 Then GoTo lbl_Exit
                If lAsk = 6 Then
                    oRng.Text = vReplaceText(i)
                    oRng.Font.Name = "Times New Roman"
                End If
                oRng.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    Exit Sub
End Sub

Sub Macro2()
Dim vFindText As Variant
Dim vReplaceText As Variant
Dim oRng As Range
Dim i As Integer
Dim lAsk As Long

    vFindText = Array(Chr(176), Chr(177))
    vReplaceText = Array(ChrW(61616), ChrW(61617))
    For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            Do While .Execute
                oRng.Select
                lAsk = MsgBox("Replace Symbol", vbYesNoCancel)
                If lAsk = 2 Then GoTo lbl_Exit
                If lAsk = 6 Then
                    oRng.Text = vReplaceText(i)
                    oRng.Font.Name = "Symbol"
                End If
                oRng.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    Exit Sub
End Sub

---

Those macros run in the required way (finding matches and prompting the user to replace or skip), thank you.

However, they don't produce the required output exactly. There are two issues, a different one in each macro.

- With Macro #1 (replacing characters in the Symbol font with ones in the normal font), the font of the replacement characters should not be specified by the macro but should be simply the font of the surrounding text. Removing line 19 (oRng.Font.Name = "Times New Roman") appears to resolve this issue.

- With Macro #2 (replacing characters in the normal font with ones in the Symbol font), the replacement characters have the right look but also have compatibility issues, which these macros are intended to circumvent. It appears these characters must be produced using the InsertSymbol function. When they have been produced in this way, double-clicking on them opens the InsertSymbol dialog box; and when they are selected, the font field in the ribbon shows the font of the surrounding text, not "Symbol". When I recorded a macro in which I produced these characters in this way, the part of the code that produced the characters was as follows.

Code:

---

Selection.InsertSymbol Font:="Symbol", CharacterNumber:=-3920, Unicode:=True

---

(The character number is -3920 for the degree symbol, and -3919 for the plus-or-minus symbol.)

Is it possible to modify Macro #2 to use this method?

Have you tried?

Code:

---

oRng.Font.Name = "Symbol", CharacterNumber:=-3920, Unicode:=True"

---

Do you mean try replacing line 19 in Macro #2 ...

Code:

---

oRng.Font.Name = "Symbol"

---

... with this?

Code:

---

oRng.Font.Name = "Symbol", CharacterNumber:=-3920, Unicode:=True

---

When I tried that just now, it said "Compile error: Expected: end of statement" with the first comma highlighted.

If it did work, I think the character number would need to be replaced by a variable though, because the character number is different for each character (-3920 = degree, -3919 = plus-or-minus) and so would need to change for each iteration of the loop, but I don't know enough VBA to get it working.

To fix the issue as suggested, change Macro2 to

Code:

---

Sub Macro2()
Dim vFindText As Variant
Dim vReplaceText As Variant
Dim oRng As Range
Dim i As Integer
Dim lAsk As Long

    vFindText = Array(Chr(176), Chr(177))
    vReplaceText = Array(-3920, -3919)
    For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            Do While .Execute
                oRng.Select
                lAsk = MsgBox("Replace Symbol", vbYesNoCancel)
                If lAsk = 2 Then GoTo lbl_Exit
                If lAsk = 6 Then
                    oRng.InsertSymbol Font:="Symbol", _
                                      CharacterNumber:=vReplaceText(i), _
                                      Unicode:=True
                End If
                oRng.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    Exit Sub
End Sub

---

That works fine, thanks.

Is it possible to modify this further so it will only find characters from a specific font?

Is it also possible to add a message if no matches are found?

If there are no matches, you won't get the prompt to change it. However:

Code:

---

Sub Macro2()
Dim vFindText As Variant
Dim vReplaceText As Variant
Dim oRng As Range
Dim i As Integer, j As Integer, k As Integer, m As Integer
Dim lAsk As Long
Const strFontName As String = "Times New Roman" 'The font to search

    vFindText = Array(Chr(176), Chr(177))
    vReplaceText = Array(-3920, -3919)
    j = 0: k = 0: m = 0
    For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            .Font.Name = strFontName
            Do While .Execute
                j = j + 1
                oRng.Select
                lAsk = MsgBox("Replace Symbol", vbYesNoCancel)
                If lAsk = 2 Then GoTo lbl_Exit
                If lAsk = 6 Then
                    k = k + 1
                    oRng.InsertSymbol Font:="Symbol", _
                                      CharacterNumber:=vReplaceText(i), _
                                      Unicode:=True
                Else
                    m = m + 1
                End If
                oRng.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    If j = 0 Then MsgBox "There are no matches", vbInformation
    If k > 0 Or m > 0 Then MsgBox k & " substitutions made" & vbCr & _
      m & " substitutions skipped", vbInformation
    Exit Sub
End Sub

---

That works fine, thanks again.

I have now made a Macro #3 based on Macro #2, with a different set of characters to find and replace (the first four letters of the Greek alphabet).

Code:

---

Sub Macro3()
Dim vFindText As Variant
Dim vReplaceText As Variant
Dim oRng As Range
Dim i As Integer, j As Integer, k As Integer, m As Integer
Dim lAsk As Long
Const strFontName As String = "Symbol" 'The font to search


    vFindText = Array(ChrW(61537), ChrW(61538), ChrW(61543), ChrW(61540))
    vReplaceText = Array(-3999, -3998, -3993, -3996)
    j = 0: k = 0: m = 0
    For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            .Font.Name = strFontName
            Do While .Execute
                j = j + 1
                oRng.Select
                lAsk = MsgBox("Replace Symbol", vbYesNoCancel)
                If lAsk = 2 Then GoTo lbl_Exit
                If lAsk = 6 Then
                    k = k + 1
                    oRng.InsertSymbol Font:="Symbol", _
                                      CharacterNumber:=vReplaceText(i), _
                                      Unicode:=True
                Else
                    m = m + 1
                End If
                oRng.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    If j = 0 Then MsgBox "There are no matches", vbInformation
    If k > 0 Or m > 0 Then MsgBox k & " substitutions made" & vbCr & _
      m & " substitutions skipped", vbInformation
    Exit Sub
End Sub

---

This version should:
- (1) find each of the specified characters in the Find array, then
- (2) remove the Symbol font formatting from each match, then
- (3) replace the match from the replace array (the same characters but using the InsertSymbol function).

It has the code needed for steps (1) and (3), but how can step (2) be added (i.e., remove the Symbol font formatting from each match before it is replaced)? If possible, it should remove just the Symbol font formatting but retain any character formatting such as bold, italic, underline.

A test document is attached.
Attachment 30514

I think the following is what you require:

Code:

---

Option Explicit

Sub Macro3()
Dim vFindText As Variant
Dim vReplaceText As Variant
Dim oRng As Range
Dim i As Integer, j As Integer, k As Integer, m As Integer
Dim lAsk As Long
Const strFontName As String = "Symbol" 'The font to search
Dim strFontReplace As String

    vFindText = Array(ChrW(61537), ChrW(61538), ChrW(61543), ChrW(61540))
    vReplaceText = Array(-3999, -3998, -3993, -3996)
    j = 0: k = 0: m = 0
    For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            .Font.Name = strFontName
            Do While .Execute
                j = j + 1
                strFontReplace = oRng.Next.Font.Name
                oRng.Select
                lAsk = MsgBox("Replace Symbol", vbYesNoCancel)
                If lAsk = 2 Then GoTo lbl_Exit
                If lAsk = 6 Then
                    k = k + 1
                    oRng.Font.Name = strFontReplace
                    oRng.InsertSymbol Font:="Symbol", _
                                      CharacterNumber:=vReplaceText(i), _
                                      Unicode:=True
                Else
                    m = m + 1
                End If
                oRng.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    If j = 0 Then MsgBox "There are no matches", vbInformation
    If k > 0 Or m > 0 Then MsgBox k & " substitutions made" & vbCr & _
      m & " substitutions skipped", vbInformation
    Exit Sub
End Sub

---

That works fine. Thanks again.

I have now made a Macro #4 based on Macro #2, with different characters to find and replace.

Code:

---

Sub Macro4()
Dim vFindText As Variant
Dim vReplaceText As Variant
Dim oRng As Range
Dim i As Integer, j As Integer, k As Integer, m As Integer
Dim lAsk As Long


    vFindText = Array(Chr(176), Chr(186), Chr(111))
    vReplaceText = Array(-3920, -3920, -3920)
    j = 0: k = 0: m = 0
    For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            Do While .Execute
                j = j + 1
                oRng.Select
                lAsk = MsgBox("Replace Symbol", vbYesNoCancel)
                If lAsk = 2 Then GoTo lbl_Exit
                If lAsk = 6 Then
                    k = k + 1
                    oRng.InsertSymbol Font:="Symbol", _
                                      CharacterNumber:=vReplaceText(i), _
                                      Unicode:=True
                Else
                    m = m + 1
                End If
                oRng.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    If j = 0 Then MsgBox "There are no matches", vbInformation
    If k > 0 Or m > 0 Then MsgBox k & " substitutions made" & vbCr & _
      m & " substitutions skipped", vbInformation
    Exit Sub
End Sub

---

This version should find the degree symbol [Chr(176)], the masculine ordinal indicator [Chr(186)], and the letter o [Chr(111)] when it has superscript font formatting, and replace them all with the degree symbol inserted from the Symbol font. How do I specify the superscript font formatting for only the letter o; i.e., only the third item in the find array? (Can this be done by using an additional array to specify font formatting for each item in the find array; e.g., in this case "any" for the first and second items, and "superscript" for the third item?)

You can add a condition to reflect the position in the array. In the macro, you have three elements i.e. i = 0 to 2. If you want something to apply only to the third element in the array then add a condition

If i = 2 then do something

i.e.

Code:

---

For i = 0 To UBound(vFindText)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .Text = vFindText(i)
            If i = 2 Then .Font.Superscript = True
            Do While .Execute
                j = j + 1
                oRng.Select
                lAsk = MsgBox("Replace Symbol", vbYesNoCancel)
                If lAsk = 2 Then GoTo lbl_Exit
                If lAsk = 6 Then
                    k = k + 1
                    If i = 2 Then oRng.Font.Superscript = False
                    oRng.InsertSymbol Font:="Symbol", _
                                      CharacterNumber:=vReplaceText(i), _
                                      Unicode:=True
                Else
                    m = m + 1
                End If
                oRng.Collapse 0
            Loop
        End With
    Next i

---

That works fine. Thanks again.