Hi Orge,
Try this code:
Sub Anonymiser()
Application.ScreenUpdating = False
Dim FileList As Variant, ChkDoc As Document, TestDoc As Document, FilePath As String, ChkList As String, j As Long
'Load the strings from the reference doc into a text string to be used as an array.
Set ChkDoc = Documents.Open("D:\Anonymouse\Checklists\Checklist.doc")
ChkList = ChkDoc.Range.Text: ChkDoc.Close False: Set ChkDoc = Nothing
'Get the path to the documents to process
FilePath = InputBox("Please input the path to the documents to process", "Path to Files", ActiveDocument.Path)
'Exit if the filepath is empty
If FilePath = "" Then GoTo Done
'Ensure the filepath ends with "\"
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
'Get a list of all documents in the target folder
FileList = Dir(FilePath & "*.doc", vbNormal)
'Process each found file
While FileList <> ""
Set TestDoc = Documents.Open(FilePath & FileList)
With TestDoc.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Color = wdColorRed
.Replacement.Text = "[NAME REMOVED]"
.MatchWholeWord = True
.MatchCase = True
'Process each word from the Check List
For j = 0 To UBound(Split(ChkList, vbCr))
.Text = Split(ChkList, vbCr)(j) & "'s"
.Execute Replace:=wdReplaceAll
.Text = Split(ChkList, vbCr)(j)
.Execute Replace:=wdReplaceAll
Next
End With
TestDoc.Close True
FileList = Dir()
Wend
'Clean up and exit
Done:
Set TestDoc = Nothing
Application.ScreenUpdating = True
End Sub
Notes:
1. Screen updating is turned off, but you'll probably see some flickering as each new document is loaded.
2. The checklist document is opened, data gathered, then closed.
3. You're asked to nominate the folder to process. The code then processes all files in that folder without further intervention.
4. The Find/Replace loop has been optimised to eliminate the unnecessary resetting of variables on each iteration
5. Possessive cases are catered for.