Help me optimize VBA code

[ivanov.ivaylo]

I have docs in Word with contain IPA (International Phonetic Alphabet)
symbols used to indicate the pronumciation of the words. When I changed
the font these symbols appear incorrectly. I wrote a VBA macro that
converts the incorrect symbols to the correct VBA symbols. All symbols
that are part of the pronunciation (i.e. need to be VBA) are written in
a red font to be differentiated from the remaining symbols. These is so
because some of the red symbols coincide with non-red symbols and only
the red ones must be converted.

Help me to optimize this macro:

Sub ReplaceIPA2()

' "a" in "father"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(97)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(593)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "o" "pot"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9492)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(596)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "a" in "cat"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9472)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(230)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "e" in "bet"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9496)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(603)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "a" in "alone"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9474)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(601)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "u" in "cut"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9484)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(652)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "ng" in "sing"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9532)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(331)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "th" in "thin"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9500)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(952)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "th" in "this"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9508)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(240)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "s" in "pleasure"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9524)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(658)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' "sh" in "ship"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9516)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(643)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' primary stress
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9563)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(712)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' secondary stress
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(9562)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(716)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

' length mark
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ChrW(58)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(720)
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

End Sub

 

[Dave Lett]

Hi,

Are you looking for something like the following:

Sub ReplaceIPA2()
Dim aFind
Dim aReplace
Dim iCount As Integer
aFind = Array("97", "9492", "9472", "9496", "9474", "9484", "9532", "9500",
_
"9508", "9524", "9516", "9563", "9562", "58")
aReplace = Array("593", "596", "230", "603", "601", "652", "331", "952", _
"240", "658", "643", "712", "716", "720")

For iCount = 0 To UBound(aFind)
With Selection.Find
.ClearFormatting
.Text = ChrW(aFind(iCount))
.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
With .Replacement
.ClearFormatting
.Text = ChrW(aReplace(iCount))
.Font.Color = wdColorRed
End With
.Execute Replace:=wdReplaceAll
End With
Next iCount
End Sub


HTH,
Dave

 

[Helmut Weber]

Hi Dave,

have you tested it?

To me it seems, replacement doesn't work.

There are some red characters "a" in my doc.
Font is Arial.

The following does nothing at all:

Sub test0115()
ActiveDocument.Range(0, 0).Select
With Selection.Find
.Text = ChrW(97)
.Font.Color = wdColorRed
.Replacement.Text = ChrW(593)
.Format = True
.Execute wdReplaceAll
End With
End Sub

This one replaces the first "a"
and the first "a" only by chrW(593):

Sub test0113()
Dim rDcm As Range
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Text = ChrW(97)
.Font.Color = wdColorRed
.Format = True
While .Execute
rDcm.Text = ChrW(593)
Wend
End With
End Sub

This one replaces all, here and now,
and there are no more options required:

Sub test0113()
Dim rDcm As Range
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Text = ChrW(97)
.Font.Color = wdColorRed
.Format = True
While .Execute
rDcm.Text = ChrW(593)
rDcm.Start = rDcm.End '<<
Wend
End With
End Sub

@ivanov:

Constructing a loop around it.
like chrFound(i), chrReplace(i),
shouldn't be that difficult.

You may have to set the line spacing to exactly,
as the characters with high unicode numbers
seem not to fit into the usual size pattern.
Poorly designed. :-(

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Dave Lett]

Hi Helmut,

Yes, I tested it. I ran the following routine about 4 times before I ran the
replacement routine:

Dim aFind
Dim aReplace
Dim iCount As Integer
aFind = Array("97", "9492", "9472", "9496", "9474", "9484", "9532", "9500",
_
"9508", "9524", "9516", "9563", "9562", "58")
aReplace = Array("593", "596", "230", "603", "601", "652", "331", "952", _
"240", "658", "643", "712", "716", "720")

For iCount = 0 To UBound(aFind)
ActiveDocument.Range.InsertAfter Text:=ChrW(aFind(iCount)) & vbCrLf
Next iCount
ActiveDocument.Range.Font.Color = wdColorRed

This way, I'm sure to have the character that the OP is looking to replace.
I tested it again this morning, and I still get valid replacements. I don't
know why your replace isn't working.

Dave

 

[Helmut Weber]

Hi Dave,

if the OP was helped, it's alright.

Maybe one shouldn't try to lift all secrets.

Just out of curiosity,
what version of Word and what version of Windows
have you got?

 

[Dave Lett]

Hi Helmut,

Between the two offered solutions, I'm sure the OP was helped, so good.

I 'm running Word 2003, SP2 on Windows XP, SP2

Cheers,
Dave

 

[Tony Jollans]

Hi Helmut,

Your first code - using Selection *may* fail due to persistence in
Selection.Find object - what was your previous Selection.Find?

Your second, after replacing rDcm.Text then does a search (in the loop) on
rDcm range and doesn't find what you were previously looking for. You need
to collapse rDcm after setting the Text (which is effectively what you do in
the third case).

 

[Helmut Weber]

Hi Tony,

the first code fails because of
..Execute wdReplaceAll

instead of
..Execute Replace:=wdReplaceAll

I thought I had seen the shorter version used before.

I don't know why I even tried the second example.
I've explained myself here 100 times how to do it.

Wasn't my day.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Tony Jollans]

the first code fails because of

.Execute wdReplaceAll

instead of
.Execute Replace:=wdReplaceAll

Of course

 

[ivanov.ivaylo]

Hi Dave,

Your code works OK with me. Thank you very much!

I want to ask you a silly question but I'm not a programmer after all:

How should I construct my variables in the brackets if I want one
caracter to be replaced by two? For example: 1117 with 1080 + 768 (=
cyrillic "i" plus a combining accute accent),

aFind = Array("9552", "9553", "157", "9555", "1117")
aReplace = Array("224", "232", "233", "242", "1080""768")

Thanks again


aFind = Array("97",

 

[Dave Lett]

Hi,

The easiest workaround would be to include "1117" in the aFind array twice:

aFind = Array("9552", "9553", "157", "9555", "1117", "1117")
aReplace = Array("224", "232", "233", "242", "1080", "768")

HTH,
Dave

 

[ivanov.ivaylo]

Hi Dave,

Thanks for cooperation.

This method does not work because the first time the macro searches for
1117 and replaces it with 1080 and the second time the macro cannot
find any instances of 1117 to replace them with 768.

Is there a way to search for 1117 and replace them with 1080 and 768 in
a one go:

Sub ReplaceIPA2()
Dim aFind
Dim aReplace
Dim iCount As Integer
aFind = Array("9552", "9553", "157", "9555", "1117", "1117")
aReplace = Array("224", "232", "233", "242", "1080", "768")
For iCount = 0 To UBound(aFind)
With Selection.Find
.ClearFormatting
.Text = ChrW(aFind(iCount))
.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
With .Replacement
.ClearFormatting
.Text = ChrW(aReplace(iCount))
.Font.Color = wdColorRed
End With
.Execute Replace:=wdReplaceAll
End With
Next iCount
End Sub

 

[Tony Jollans]

You will need to devise a way of specifying the multiple characters, perhaps
like this:

Sub ReplaceIPA2()
Dim aFind
Dim aReplace
Dim iCount As Integer
aFind = Array("9552", "9553", "157", "9555", "1117")
aReplace = Array("224", "232", "233", "242", "1080,768")
For iCount = 0 To UBound(aFind)
With Selection.Find
.ClearFormatting
.Text = ChrW(aFind(iCount))
.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
With .Replacement
.ClearFormatting
chrs = Split(aReplace(iCount), ",")
.Text = ChrW(chrs(0))
For i = 1 To UBound(chrs)
.Text = .Text & ChrW(chrs(i))
Next
.Font.Color = wdColorRed
End With
.Execute Replace:=wdReplaceAll
End With
Next iCount
End Sub

 

[Dave Lett]

Yes. I'm sorry; I misunderstood the question.

This should work:
For iCount = 0 To UBound(aFind)
With Selection.Find
.ClearFormatting
.Text = ChrW(aFind(iCount))
.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = False
With .Replacement
.ClearFormatting
If aFind(iCount) <> "1117" Then
.Text = ChrW(aReplace(iCount))
Else
Selection.HomeKey Unit:=wdStory
.Text = ChrW(aReplace(iCount)) & ChrW(768)
End If
End With
.Execute Replace:=wdReplaceAll
End With
Next iCount

However, the combination of ChrW(1080) & ChrW(768) _appears_ be the same as
the single character ChrW(1117) when I use Search/Replace. When I use

ActiveDocument.Range.InsertAfter Text:=ChrW(1080) & ChrW(768)

They appear to be completely different.

HTH,
Dave