title: Excel VBA Macro, Find and Replace text in Word Documents, with an output text file
body: <p>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!</p>
  <p>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.</p>
  <p>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...</p>
  <p>I would be really grateful if someone could perhaps suggest a good way to make the reporting text file tidier? - i.e only reporting on the actual find and replace made, with no duplicate lines.</p>
  <p>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.</p>
  <p>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:</p>
  <blockquote>
  <p>File, Find, Replacement, Time</p>
  <p>H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:02<br />
  H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:02<br />
  H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:02<br />
  H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:02<br />
  H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:02<br />
  H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:02<br />
  H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:02<br />
  H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:02<br />
  H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:02<br />
  H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:03<br />
  H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:03<br />
  H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:03<br />
  H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:03<br />
  H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:03<br />
  H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:03<br />
  H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:03<br />
  H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:04<br />
  H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:05<br />
  H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:05<br />
  H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:05<br />
  H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:05<br />
  H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:05<br />
  H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:05</p>
  </blockquote>
  <p>Code:</p>
  <pre><code>'~~&gt; 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
  
  '~~&gt; This is the extention you want to go in for
  strFilePattern = &quot;*.do*&quot;
  
  '~~&gt; Establish an Word application object
  On Error Resume Next
  Set oWordApp = GetObject(, &quot;Word.Application&quot;)
  
  If Err.Number &lt;&gt; 0 Then
      Set oWordApp = CreateObject(&quot;Word.Application&quot;)
  End If
  Err.Clear
  On Error GoTo 0
  
  oWordApp.Visible = True
  
  '~~&gt; Loop through the folder to get the word files
    
  strFileName = Dir$(sFolder &amp; &quot;\&quot; &amp; strFilePattern)
  
  
  whatChanged = &quot;File, Find, Replacement, Time&quot; &amp; vbCrLf
  Print #FileNum, whatChanged
  
  Dim i, j
      i = 0 ' count of files found
      j = 0 ' count of files that matched
  
  Do Until strFileName = &quot;&quot;
      
      i = i + 1
      
      sFileName = sFolder &amp; &quot;\&quot; &amp; strFileName
  
      '~~&gt; Open the word doc
      Set oWordDoc = oWordApp.Documents.Open(sFileName)
      Set rngXL = Sheets(1).Range(&quot;A2:A&quot; &amp; Range(&quot;A2&quot;).End(xlDown).Row)
     
      '~~&gt; 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 &amp; &quot;|&quot; &amp; strFind &amp; &quot;|&quot; &amp; strReplace &amp; &quot;|&quot; &amp; Now()
             Print #FileNum, whatChanged
          Next
         
      Next
  
      '~~&gt; Close the file after saving
      oWordDoc.Close SaveChanges:=True
  
      '~~&gt; Find next file
      strFileName = Dir$()
  Loop
  
  'Call writeToFile(whatChanged, savePath)
  
  MsgBox (&quot;Found &quot; &amp; i &amp; &quot; files and &quot; &amp; j &amp; &quot; replacements made&quot;)
  
  '~~&gt; Quit and clean up
  oWordApp.Quit
  
  Set oWordDoc = Nothing
  Set oWordApp = Nothing
  
  End Sub
  
  Sub writeToFile(text, path)
  Set objFso = CreateObject(&quot;Scripting.FileSystemObject&quot;)
  
  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 &amp; &quot;\FindAndReplaceAuditFile.TXT&quot;
  
  Open OutputTxt For Output As FileNum
  
  Call WordReplace(searchPath, savePath)
  
  Close #FileNum
  
  End Sub
  </code></pre>