Help me optimize VBA code

Thread view:

Enable EMail Alerts

Start New Thread

Thread rating:

ivanov.ivaylo@gmail.com - 05 Apr 2006 13:58 GMT

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

Reply to this Message

Dave Lett - 05 Apr 2006 17:35 GMT

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

>I have docs in Word with contain IPA (International Phonetic Alphabet)
> symbols used to indicate the pronumciation of the words. When I changed
[quoted text clipped - 206 lines]
>
> End Sub

Reply to this Message

Helmut Weber - 05 Apr 2006 22:59 GMT

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. :-(

Signature

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

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

Reply to this Message

Dave Lett - 06 Apr 2006 12:35 GMT

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

> Hi Dave,
>
[quoted text clipped - 61 lines]
> seem not to fit into the usual size pattern.
> Poorly designed. :-(

Reply to this Message

Helmut Weber - 06 Apr 2006 14:51 GMT

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?

Signature

Greetings from Bavaria, Germany
Helmut Weber, MVP WordVBA
"red.sys" & chr(64) & "t-online.de"
Word 2002, Windows 2000

Reply to this Message

Dave Lett - 06 Apr 2006 15:02 GMT

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

> Hi Dave,
>
[quoted text clipped - 5 lines]
> what version of Word and what version of Windows
> have you got?

Reply to this Message

Tony Jollans - 06 Apr 2006 15:16 GMT

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).

--
Enjoy,
Tony

> Hi Dave,
>
[quoted text clipped - 69 lines]
> Win XP, Office 2003
> "red.sys" & Chr$(64) & "t-online.de"

Reply to this Message

Helmut Weber - 06 Apr 2006 15:44 GMT

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.

Signature

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

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

Reply to this Message

Tony Jollans - 06 Apr 2006 16:38 GMT

> the first code fails because of
> .Execute wdReplaceAll
>
> instead of
> .Execute Replace:=wdReplaceAll

Of course :-)

--
Enjoy,
Tony

Reply to this Message

ivanov.ivaylo@gmail.com - 06 Apr 2006 21:08 GMT

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",

Reply to this Message

Dave Lett - 06 Apr 2006 21:19 GMT

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

> Hi Dave,
>
[quoted text clipped - 12 lines]
>
> aFind = Array("97",

Reply to this Message

ivanov.ivaylo@gmail.com - 07 Apr 2006 08:08 GMT

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

Reply to this Message

Tony Jollans - 07 Apr 2006 13:22 GMT

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

--
Enjoy,
Tony

> Hi Dave,
>
[quoted text clipped - 30 lines]
> Next iCount
> End Sub

Reply to this Message

Dave Lett - 07 Apr 2006 13:24 GMT

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

> Hi Dave,
>
[quoted text clipped - 30 lines]
> Next iCount
> End Sub

Reply to this Message