Find and Replace too Slow

[rpick60]

I have some large docs that I do find and replace and it takes a long
time to do with a vb macro.
I grab 2 columns from excell and paste in a template and then run a
macro which opens txt file and looks for the first cell in the table
and replaces it with the second cell. It then moves tot the next row
and does it all over again.
The problem is the txt file opens in word and takes 2 minutes and 4
minutes to run the macro. The file size is 8 MB. I can live with time
it takes but I got files as big as 150MB and it will take 20 hours to
run. I have narrowed it down to the find and replace. It takes about
3 minutes for each row and I may have 400 to 500 rows.

Is there a better way to do find and replace.

Here is some of my code.


Private Sub cmdOK_Click()


Dim objMe As Document
Dim oWordDoc As Document
Dim OWordApp As Word.Application
Dim objTemplate As Template
Dim sFindAndReplaceTemplateName As String
Dim nRows As Long
Dim nRow As Long
Dim sSourceText As String
Dim sTargetText As String
Dim myrange As Range
Dim nListRows As Long
Dim nListRow As Long
Dim sFileName As String
Dim bDocumentChanged As Boolean
Dim sTargetText1 As String

On Error Resume Next

If MsgBox("This Find and Replace feature will work on the selected
documents." & vbCrLf & vbCrLf & _
" Is this what you want?", _
vbYesNo + vbDefaultButton2 + vbQuestion, _
"Dragon Drop's Find and Replace v1.2") = vbNo Then
Exit Sub
End If

Set objMe = ActiveDocument

' Make a note of the F&R template name in case the user renames it.
Set objTemplate = ActiveDocument.AttachedTemplate
sFindAndReplaceTemplateName = objTemplate.Name
Set objTemplate = Nothing

' Determine the number of rows in the table
nRows = ActiveDocument.Tables(1).Rows.Count
nListRows = lstFilesFound.ListCount

For nListRow = 0 To nListRows - 1
If lstFilesFound.Selected(nListRow) Then

sFileName = lstFilesFound.List(nListRow)

' lblFeedback.Caption = sFileName
' DoEvents

'Word.Application.Visible = False
Set oWordDoc = Documents.Open(sFileName)
oWordDoc.Activate
Word.ActiveDocument.Application.Visible = False
bDocumentChanged = False

Set objTemplate = oWordDoc.AttachedTemplate
If InStr(1, objTemplate.Name, sFindAndReplaceTemplateName,
vbTextCompare) = 0 Then

For nRow = 1 To nRows
sSourceText = objMe.Tables(1).Cell(nRow, 1).Range.Text
sSourceText = Left$(sSourceText, Len(sSourceText) - 2)
sTargetText = objMe.Tables(1).Cell(nRow, 2).Range.Text
sTargetText = Left$(sTargetText, Len(sTargetText) - 3)
sTargetText1 = sTargetText & "'"
If Len(sSourceText) > 0 Then

Set myrange = ActiveDocument.Content
With myrange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = sSourceText
.Replacement.Text = sTargetText1
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With

bDocumentChanged = True
End If
ActiveDocument.UndoClear
Next nRow

End If

 

[Graham Mayor]

Whether it will be any quicker than your macro I cannot say, but try the
following.
sFname = "D:\My Documents\Test\changes.doc" would be the document with the
two column table of words and replacements. You may need to change the find
options to match your requirements

Sub ReplaceFromTableList()

Dim ChangeDoc As Document, RefDoc As Document
Dim cTable As Table
Dim oldPart As Range, newPart As Range
Dim i As Long
Dim sFname As String

sFname = "D:\My Documents\Test\changes.doc"
Set RefDoc = ActiveDocument
Set ChangeDoc = Documents.Open(sFname)
Set cTable = ChangeDoc.Tables(1)
RefDoc.Activate
For i = 1 To cTable.Rows.Count
Set oldPart = cTable.Cell(i, 1).Range
oldPart.End = oldPart.End - 1
Set newPart = cTable.Cell(i, 2).Range
newPart.End = newPart.End - 1
With Selection
.HomeKey wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Execute findText:=oldPart, _
ReplaceWith:=newPart, _
Replace:=wdReplaceAll, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
Forward:=True, _
Wrap:=wdFindContinue
End With
End With
Next i
ChangeDoc.Close wdDoNotSaveChanges
End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>