Excel VBA Macro, Find and Replace text in Word Documents, with an output text file

Question

I have aquired this very handy piece of code that via an excel button searches through a folder and performs a find and replace on all word documents depending on criteria input in column A and B of an Excel worksheet, it also provides a msgbox to show how many files have been found and replacement loops have been made. This code opens each word document in turn, does the find and replace, then saves the new document. It also outputs a text file to report what has changed and where. BUT!

My question is to do with that reporting txt file, currently I think it is set up (code called 'whatchanged') to write a line each time it cycles through the Range 'Stories' within the word docs, it is therefore writing duplicate lines on the report file for each story it searches through rather than just one line for what has actually been found and replaced.

I'm struggling to think of a way to make this code output one line only to show what has changed without any duplicates. It also seems to output a line on the text file even when no find and replace has been made for each range story! so not very useful...

I would be really grateful if someone could perhaps suggest a good way to make the reporting text file tidier? - ie only reporting on the actual find and replace made, with no duplicate lines.

Any help /suggestions you could give will be very much appreciated, note that I'm new to this forum and to vba so i'm trying my best to learn from others and research code as i go. I also posted this in the hope this code may be useful to others too if your searching for something similar.

btw.. Heres an example below of the text file output for just one test document!, sorry if this isnt very clear... this was created after running the code with a few testing find and replaces being entered on the excel sheet - you can see what i mean about the duplication:

File, Find, Replacement, Time

H:\\Letters Test\\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:02
H:\\Letters Test\\Doc1.doc|October|November|15/10/2013 11:06:02
H:\\Letters Test\\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:02
H:\\Letters Test\\Doc1.doc|2013|2014|15/10/2013 11:06:02
H:\\Letters Test\\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:02
H:\\Letters Test\\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:02
H:\\Letters Test\\Doc1.doc|October|November|15/10/2013 11:06:02
H:\\Letters Test\\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:02
H:\\Letters Test\\Doc1.doc|2013|2014|15/10/2013 11:06:02
H:\\Letters Test\\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:03
H:\\Letters Test\\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:03
H:\\Letters Test\\Doc1.doc|October|November|15/10/2013 11:06:03
H:\\Letters Test\\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:03
H:\\Letters Test\\Doc1.doc|2013|2014|15/10/2013 11:06:03
H:\\Letters Test\\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:03
H:\\Letters Test\\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:03
H:\\Letters Test\\Doc1.doc|October|November|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|2013|2014|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|October|November|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|2013|2014|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|October|November|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|2013|2014|15/10/2013 11:06:04
H:\\Letters Test\\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:05
H:\\Letters Test\\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:05
H:\\Letters Test\\Doc1.doc|October|November|15/10/2013 11:06:05
H:\\Letters Test\\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:05
H:\\Letters Test\\Doc1.doc|2013|2014|15/10/2013 11:06:05
H:\\Letters Test\\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:05

Code:

'~~> Defining Word Constants
Const wdFindContinue As Long = 1
Const wdReplaceAll As Long = 2

Public FileNum As Integer
Public OutputTxt As String


Sub WordReplace(sFolder, savePath)
Dim oWordApp As Object, oWordDoc As Object, rngStory As Object
Dim strFilePattern As String
Dim strFileName As String, sFileName As String
Dim rngXL As Range
Dim x As Range
Dim strFind As String
Dim strReplace As String
Dim whatChanged As String

'~~> This is the extention you want to go in for
strFilePattern = "*.do*"

'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")

If Err.Number <> 0 Then
    Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0

oWordApp.Visible = True

'~~> Loop through the folder to get the word files

strFileName = Dir$(sFolder & "\" & strFilePattern)


whatChanged = "File, Find, Replacement, Time" & vbCrLf
Print #FileNum, whatChanged

Dim i, j
    i = 0 ' count of files found
    j = 0 ' count of files that matched

Do Until strFileName = ""

    i = i + 1

    sFileName = sFolder & "\" & strFileName

    '~~> Open the word doc
    Set oWordDoc = oWordApp.Documents.Open(sFileName)
    Set rngXL = Sheets(1).Range("A2:A" & Range("A2").End(xlDown).Row)

    '~~> Do Find and Replace
    For Each rngStory In oWordDoc.StoryRanges

        For Each x In rngXL
            strFind = x.Value
            strReplace = x.Offset(0, 1).Value
            j = j + 1
            With rngStory.Find
                .text = strFind
                .Replacement.text = strReplace
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
           whatChanged = sFileName & "|" & strFind & "|" & strReplace & "|" & Now()
           Print #FileNum, whatChanged
        Next

    Next

    '~~> Close the file after saving
    oWordDoc.Close SaveChanges:=True

    '~~> Find next file
    strFileName = Dir$()
Loop

'Call writeToFile(whatChanged, savePath)

MsgBox ("Found " & i & " files and " & j & " replacements made")

'~~> Quit and clean up
oWordApp.Quit

Set oWordDoc = Nothing
Set oWordApp = Nothing

End Sub

Sub writeToFile(text, path)
Set objFso = CreateObject("Scripting.FileSystemObject")

Dim objTextStream
Set objTextStream = objFso.OpenTextFile(path, 8, True)

'Display the contents of the text file
objTextStream.WriteLine text

'Close the file and clean up
objTextStream.Close
Set objTextStream = Nothing
Set objFso = Nothing
End Sub


Private Sub Button1_Click()
Dim objFileClass As FileClass
Set objFileClass = New FileClass

Dim searchPath, savePath
searchPath = objFileClass.SelectFolder

FileNum = FreeFile

OutputTxt = searchPath & "\FindAndReplaceAuditFile.TXT"

Open OutputTxt For Output As FileNum

Call WordReplace(searchPath, savePath)

Close #FileNum

End Sub

Answer 1

The Find.Execute method returns boolean on success. So you can write a log line only after successful replacing:

With rngStory.Find
  .text = strFind
  .Replacement.text = strReplace
  .Wrap = wdFindContinue
  If .Execute(Replace:=wdReplaceAll) Then
    whatChanged = sFileName & "|" & strFind & "|" & strReplace & "|" & Now()
    Print #FileNum, whatChanged
  End If
End With

Answer 2

I see two options:

1) You write a condition before writing the string to the file;
2) You execute some VBA on the file to filter duplicate strings.

Considering the first option, there are a few ways you can go:

1) Read the file and compare the new string to what is already in the file: but this would take a long time;
2) Store the previous strings in an array and check if the new string is already in the array: this will be faster, since the process happens in memory;
3) Personally I would go with a dictionary, if the length of the search string is acceptable. A dictionary has a structure where you can store key - value pair records.
The dictionary has a typical Exists method that checks whether a certain key already exists in the structure. I don't think that this key allows spaces, but you can replace these spaces by underscores.
In this case you would store each search string as a key in the dictionary, on the condition that the key (the search string) does not exist yet.

The structure of a dictionary:

Dim dict As New Scripting.Dictionary 
dim sFind_value as string
dim sKey as string    
dim sValue as string

sFind_value = trim("whatever value")
sKey = replace(sFind_value, " ", "_")
sValue = "whatever"

If Not dict.Exists(sKey) Then 
    dict.Add sKey, sValue
    'Write to file
End If 

Let me know if this is helpful, or if you need more help on the subject.