FindReplace macro speed

[FotoArt]

Hello everyone

what im trying to do is remove all the tags of a text document and
replace the remaining characters with selected special characters.
I have been able to remove the tags with a word macro. And do the rest
it working.
And below is only a part of my code.


this is part of my code.


With Selection.Find
.Text = "</P>"
.Replacement.Text = "^p^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "[<]*[>]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "h"
.Replacement.Text = ChrW(1920)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With


It goes on and on until all the letters are swapped as i want it to be.
The problem is when I run it on a 500 page document.
Its taking more than half an hour and some times not responding.


If anyone could give me any ideas on how I could improve my code andspeed
things up.
My code is very crude.


Any help would be appreciated.


thanx
ahmed

 

[Helmut Weber]

Hi Ahmed,

I doubt, whether range is faster than selection,
if all of the doc will be processed.
But it is worth a try.
Saves you a lot of code, anyway,
as the search in a new range doesn't remember
the settings that were there before, like with selection.

I'm assuming, you know the usual methods for speeding up,
like minimizing the application window or hiding
the application altogether.

With large documents and lots of editing, IMHO, there was,
at last in the past, a point in time,
when Word couldn't handle any longer the complexity it was creating.

So:
Minimize the application
Use range
Save the doc in between, with .AllowFastSave = False
preferably with another name, like mydoc-01, mydoc-02, mydoc-03.

With range your code would look like this, untested:

Dim rTmp as range
set rTmp = activedocument.range
with rtmp.find
.text = "this"
.replacement.text = "that"
.execute replace:=wdreplaceall
.text = "she"
.replacement.text = "he"
.execute replace:=wdreplaceall
.text = "what"
.replacement.text = "who"
.execute replace:=wdreplaceall
end with

Admittedly, somewhat demanding.

HTH

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

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

 

[AirW]

Hi Amed

I wrote a similar macro a while ago It runs pretty fast but I never try
on 500 pages

You dont have to change the formating for every the seach and replace
each time you look for a new letter

The code is than much more quick to write/read and houskeeping is
easier

Sub Substitute_Entities()

'Purpose: Substitute all kind of Entities to simplify the correction
an let the text look as a 'regular text
' Makro aufgezeichnet am 10.07.01 von Hervé Larroque

Dim strSearch As String 'this variable hold what you
search
Dim strReplace As String 'this variable hold the remplacement text
Dim intCount As Integer 'this variable will hold the number of seach
done
On Error Resume Next

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting

For intCount = 1 To 18 ' here you must change the number of loop for
your needs ini my case '18 entities
will be searched

Select Case intCount

Case 1 'Replace &
strSearch = "&amp;"
strReplace = "&"
Case 2 'replace non breakable space
strSearch = "&nbsp;"
strReplace = "^s"
Case 3 'Replace wide dash
strSearch = "&mdash;"
strReplace = "-"
Case 4 'Replace narrow dash
strSearch = "&ndash;"
strReplace = "-"
Case 5 'Replace left and right quotes
strSearch = "&rdquo;"
strReplace = """"
Case 6
strSearch = "&ldquo;"
strReplace = """"
Case 7 'first replace the "n&deg;" by Nº / nº
strSearch = "n&deg;"
strReplace = "nº"
Case 8 'now replace the ºC / ºF with a space before
digit
strSearch = "&deg;"
strReplace = " º"
Case 9 'Replace &plusmn; by ±
strSearch = "&plusmn;"
strReplace = "±"
Case 10 'Replace &dot; by "."
strSearch = "&dot;"
strReplace = "o"
Case 11 'Replace "&gt;" ">"
strSearch = "&gt;"
strReplace = ">"
Case 12 'Replace "&lgt;" ",<"
strSearch = "&lt;"
strReplace = "<"
Case 13 'replace the Ohm sign by ohm
strSearch = "&OHgr;"
strReplace = "ohm"
Case 14
strSearch = "&ohm;"
strReplace = "ohm"
Case 15 'Replace &Reg; by ® (registred)
strSearch = "&Reg;"
strReplace = "®"
Case 16 'Replace &divide;by :
strSearch = "&divide;"
strReplace = ":"
Case 17 'Replace &rsquo;by :'
strSearch = "&rsquo;"
strReplace = "'"
Case 18 'Replace &copy; by :©
strSearch = "&copy;"
strReplace = "©"
End Select

With Selection.Find
.Text = strSearch
.Replacement.Text = strReplace
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
Next intCount