Help required with Find\Replace Macro - 950 Pages document

[Rashid Khan]

Hello All,
I am using Office XP/Win XP.

I have a 950 pages document and I am trying to run a macro for finding and
replacing from a Word List Document. The list is in a two column table
(about 250 rows).

The macro runs and then Word hangs. How can this be rectified?

Following is the macro I got from the NG:

Public Sub BatchFileMultiFindReplace()

'Macro by Doug Robbins - 1st March 2004
'with additional input from Peter Hewett to replace text in all the
documents in a folder
'and input from Greg Maxey to faclitate using a table for multiple find and
replace words

Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim rngstory As Word.Range

'Close any documents that may be open
If Documents.Count > 0 Then
Documents.Close SaveChanges:=wdPromptToSaveChanges
End If
' Get the folder containing the files
With Dialogs(wdDialogCopyFile)
If .Display <> 0 Then
PathToUse = .Directory
Else
MsgBox "Cancelled by User"
Exit Sub
End If
End With

If Left(PathToUse, 1) = Chr(34) Then
PathToUse = Mid(PathToUse, 2, Len(PathToUse) - 2)
End If

myFile = Dir$(PathToUse & "*.doc")

While myFile <> ""
'Open each file and make the replacement
Set myDoc = Documents.Open(PathToUse & myFile)
'Fix the skipped blank Header/Footer problem
MakeHFValid
'Iterate through all story types in the current document
For Each rngstory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
SearchAndReplaceInStory rngstory
' Get next linked story (if any)
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Close the file, saving the changes.
myDoc.Close SaveChanges:=wdSaveChanges
myFile = Dir$()
Wend
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range)
'This routine supplied by Peter Hewett and modified by Greg Maxey

Dim Source As Document
Dim i As Integer
Dim Find As Range
Dim Replace As Range
Set Source = ActiveDocument
' Change the path and filename in the following to suit where you have your
list of words
Set WordList = Documents.Open(FileName:="D:\My Documents\Word Documents\Word
Tips\Find and Replace List.doc")
Source.Activate
'I stetted out thsi Do line because it appeard to be redundant form the main
macro
'Do Until (rngstory Is Nothing)
For i = 2 To WordList.Tables(1).Rows.Count
Set Find = WordList.Tables(1).Cell(i, 1).Range
Find.End = Find.End - 1
Set Replace = WordList.Tables(1).Cell(i, 2).Range
Replace.End = Replace.End - 1
With rngstory.Find
..ClearFormatting
..Replacement.ClearFormatting
..Text = Find
..Replacement.Text = Replace
..Forward = True
..Wrap = wdFindContinue
..Format = False
..MatchCase = False
..MatchWholeWord = False
..MatchAllWordForms = False
..MatchSoundsLike = False
..MatchWildcards = False
..Execute Replace:=wdReplaceAll
End With
Next i
'Stetted out the follow for same reason
'Set rngstory = rngstory.NextStoryRange
'Loop

End Sub
Public Sub MakeHFValid()
'And this too
Dim lngJunk As Long
' It does not matter whether we access the Headers or Footers property.
' The critical part is accessing the stories range object
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub

TIA
Rashid Khan

 

[Greg]

Rashid,

I don't know what is causing the hang. Could be just your
processor biting off more than it can chew. If is just a
single document and the "words" are located in the main
body text (i.e., not in headers, footer, etc.), you can
try the following simplified macro. Also you might try
breaking your list down into small chunks.

Sub MultiFindAndReplace()
'
Dim WordList As Document
Dim Source As Document
Dim i As Integer
Dim Find As Range
Dim Replace As Range
Set Source = ActiveDocument
' Change the path and filename in the following to suit
where you have your list of words
Set WordList = Documents.Open(FileName:="C:\Find and
Replace List.doc")
Source.Activate
For i = 2 To WordList.Tables(1).Rows.Count
Set Find = WordList.Tables(1).Cell(i, 1).Range
Find.End = Find.End - 1
Set Replace = WordList.Tables(1).Cell(i, 2).Range
Replace.End = Replace.End - 1
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = Find
.Replacement.Text = Replace
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next i

End Sub

 

[Rashid Khan]

Hi Greg,
I have a Pentium 1.8GHz with 256 DDR, Original Intel Motherboard.
Maybe this is causing the hang.. I tried your simplified macro on 950 pages
document it worked to certain extent and then .... it crashed .. I tried the
macro on a single page document with just four Words to be replaced... I did
not break my list into small chunks.. and the macro worked fine...

I will have to test it and see what is the maximum number of pages it can
handle...

Thanks a lot for your help and time
Rashid