How to search and replace across multiple files in word?
If you have several dozen word files which contain the same content (such as Header, footer, some special words or number), and you need to replace the same content across those documents in Word. How would it be easier for you to get it done quickly? Certainly, you can open those files one by one to replace the same content, but it will be time-consuming and troublesome. This tutorial will show you a tricky way to replace same content within multiple documents in Word at once.
Office Tab: Enable Tabbed Editing and Browsing in Office, Just Like Chrome, Firefox, IE 8/9/10.
Classic Menu for Office: Bring Old Look of Office 2003 Back to Office 2007, 2010, 2013 and 2016.
Using a VBA for searching and replacing same content across multiple documents at one time in Word:
Step 1: Press “Alt-F11” to open the Microsoft Visual Basic for Application window;
Step 2: Click Module on the Insert tab, copy and paste the following VBA code into the Module window;
Step 3: Then click Run 
button to apply the VBA.
VBA: searching and replacing same content across multiple documents at one time
Sub CommandButton1_Click()
Dim MyDialog As FileDialog, GetStr(1 To 100) As String '100 files is the maximum applying this code
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.docx", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "search" 'Find What
.Replacement.Text = "find" 'Replace With
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "operation end, please view", vbInformation
End Sub
Note: you can change the Text = "search”, Replacement.Text = "find” to specify the content to be searched and the content to be applied for replacement.
Kutools for Word
More than 100 Advanced Functions for Word 2003, 2007, 2010, 2013 and 2016
Comments
I should warn you, as I've performed this dozens of times at work: The macro will result in the changes being made only to the *body* of the Word document; headers, footers, and title text/alt-text will be excluded. If you have text in the aforementioned portions that needs replacing, you will have to perform a standard find/replace across individual documents.
Anyway, my point I am going to make is a spent a lot of time on Friday troubleshooting the part where you actually put in the text you want to find and putting in the text you want to replace - I did not quite understand this part in terms of where I put my "find" word text and "replace" word text:
Quote:
I read over this again today and I wish to respectfully clarify for other programming non-initiates - in the section of VBA where you have copied and pasted the original programming language, make sure you put an end ' after the what and a ' after the with (see example below) - in my example, I am looking for multiple documents to replace Pizza with Stromboli:
.Text = "Pizza" 'Find What'
.Replacement.Text = "Stromboli" 'Replace With'
Application.Run macroname:="NEWMACROS"
and when I step into it, it tells me I have a Compile error: Named argument not found.
Now what?
EG
With Selection.Find
.Text = "HYPERLINK ""http://www.te stsite.co.uk"" " 'Find What
.Replacement.Text = "HYPERLINK ""http://www.te sttwo.co.uk"" " 'Replace With
When I run it, I get an error msg at the line:
-Windows(GetStr(j)).Activate
The error msg. is:
-Compile error:
-Sub or Function not defined
Any idea why? And how to fix it?
Private Sub CommandButton1_Click()
Dim MyDialog As FileDialog, GetStr(1 To 100) As String '100 files is the maximum applying this code
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
'~~> Change this file extention to the relevant doc type.
.Filters.Add "All WORD File ", "*.doc", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Set doc = Documents.Open( FileName:=GetSt r(j), Visible:=True)
Windows(GetStr(j)).Activate
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'Section then either one or the other of sections of code to follow.
'~~> This section if uncommented will replace text - ONLY ONE OF TWO SECTIONS CAN BE UNCOMMENTED AT ONCE
With Selection.Find
.Text = "www.google.co. uk" 'Find What
.Replacement.Text = "www.google.com " 'Replace With
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLik e = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveDocument.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "operation end, please view", vbInformation
'~~> This section if uncommented will replace hyperlinks
'For i = 1 To doc.Hyperlinks.Count
' 'If the hyperlink matches.
' If LCase(doc.Hyper links(i).Addres s) = "http://www.goo gle.co.uk/" Then
' 'Change the links address.
' doc.Hyperlinks( i).Address = "https://www.google.com"
' 'Change the links display text if desired.
' doc.Hyperlinks( i).TextToDispla y = "www.google.com "
' End If
' Next
'Application.Run macroname:="NEWMACROS"
'ActiveDocument.Save
'ActiveDocument.Close
'Next
'Application.ScreenUpdating = True
'End With
'MsgBox "operation end, please view", vbInformation
End Sub
I am trying to run your script for replacing hyperlinks but am getting errors. Any chance you can post the script for replacing hyperlinks all in 1 piece? I must be messing something up when trying to patch your code together.
Private Sub CommandButton1_Click()
Dim MyDialog As FileDialog, GetStr(1 To 100) As String '100 files is the maximum applying this code
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
'~~> Change this file extention to the relevant doc type.
.Filters.Add "All WORD File ", "*.doc", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Set doc = Documents.Open( FileName:=GetSt r(j), Visible:=True)
Windows(GetStr(j)).Activate
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
For i = 1 To doc.Hyperlinks. Count
'If the hyperlink matches.
If LCase(doc.Hyper links(i).Addres s) = "http://www.yah oo.co.uk/" Then
'Change the links address.
doc.Hyperlinks( i).Address = "https://www.go ogle.co.uk"
'Change the links display text if desired.
doc.Hyperlinks( i).TextToDispla y = "www.google.co. uk"
End If
Next
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveDocument.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "operation end, please view", vbInformation
End Sub
This worked great for the word in the body of the document but did not replace the same word in the header. Any ideas.
Thanks
How can it be achieved?
Thanks in advance
I need to perform several 'find and replace' routines for several files. Dozens of routines for dozens of files.
Is there a way to 'save' the module so I don't need to paste it again on the VBA screen every time I need to perform a new routine?
I'm a noob regarding those things
One thing though - is there any way to increase the number of words that the macro finds/replaces? I need to find/replace multiple paragraphs at once and the macro seems to have a limit of approximately 200 characters.
It is being sent in multiple parts because comments to this site can only be 2000 characters or less.
--------------- --------------- --------------- ---------------
' 500 files is the maximum applying this code
Dim MyDialog As FileDialog, GetStr(1 To 500) As String
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
' --------------- --------------- --------------- ------------------
' *.doc? allows processing of *.doc and *.docx files.
' --------------- --------------- --------------- ------------------
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.doc?", 1
.AllowMultiSele ct = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.Scr eenUpdating = False
For j = 1 To i Step 1
Set Doc = Documents.Open( FileName:=GetSt r(j), Visible:=True)
' --------------- --------------- --------------- ----------
' Beginning Header Updates
' --------------- --------------- --------------- ----------
Windows(GetStr( j)).Activate
Selection.Find. ClearFormatting
Selection.Find. Replacement.Cle arFormatting
If ActiveWindow.Vi ew.SplitSpecial wdPaneNone Then
ActiveWindow.Pa nes(2).Close
End If
If ActiveWindow.Ac tivePane.View.T ype = wdNormalView Or ActiveWindow. _
ActivePane.View .Type = wdOutlineView Then
ActiveWindow.Ac tivePane.View.T ype = wdPrintView
End If
ActiveWindow.Ac tivePane.View.S eekView = wdSeekCurrentPa geHeader
Selection.Find. ClearFormatting
Selection.Find. Replacement.Cle arFormatting
With Selection.Find
.Text = "Header String 1" ' Find What
.Replacement.Te xt = "HReplacement 1" ' Replace With
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLik e = False
.MatchAllWordFo rms = False
If .Found = True Then
ChangeMade = True
End If
End With
Selection.Find. Execute Replace:=wdRepl aceAll
' --- End header text replacemnt 1 ---
With Selection.Find
.Text = "Header String 2" ' Find What
.Replacement.Te xt = "HReplacement 2" ' Replace With
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLik e = False
.MatchAllWordFo rms = False
If .Found = True Then
ChangeMade = True
End If
End With
Selection.Find. Execute Replace:=wdRepl aceAll
' --- Beging header text replacemnt 2 ---
ActiveWindow.Ac tivePane.View.S eekView = wdSeekMainDocum ent
' --------------- --------------- --------------- ---------
' End of Header Updates
' --------------- --------------- --------------- ---------
' --------------- --------------- --------------- ----------
' Beginning of Body Updates
' --------------- --------------- --------------- ----------
Windows(GetStr( j)).Activate
Selection.Find. ClearFormatting
Selection.Find.Replacement.ClearFormatting
' ~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~ ~~~~~~~~~~
' Delete additional body replacement blocks if
' not needed or copy/paste additional blocks if
‘ required.
' ~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~ ~~~~~~~~~~
With Selection.Find
.Text = "Body text 1" ' Find What
.Replacement.Te xt = "BT1" ' Replace With
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLik e = False
.MatchAllWordFo rms = False
End With
Selection.Find. Execute Replace:=wdRepl aceAll
' --- Beging body text replacemnt 1 ---
' --- Beging body text replacemnt 2 ---
With Selection.Find
.Text = "membership" ' Find What
.Replacement.Te xt = "team members" ' Replace With
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLik e = False
.MatchAllWordFo rms = False
End With
Selection.Find. Execute Replace:=wdRepl aceAll
' --- End body text replacemnt 2 ---
With Selection.Find
.Text = "leadership" ' Find What
.Replacement.Te xt = "supervision" ' Replace With
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLik e = False
.MatchAllWordFo rms = False
End With
Selection.Find. Execute Replace:=wdRepl aceAll
' --- End body text replacemnt 3 ---
Application.Run macroname:="NEW MACROS"
ActiveDocument. Save
ActiveWindow.Cl ose
' --------------- --------------- --------------- ----------
' End of Body Updates
' --------------- --------------- --------------- ----------
Next
Application.Scr eenUpdating = True
End With
MsgBox "operation end, please view", vbInformation
End Sub
Wonderful code - thank you!! worked perfectly in executing what I needed.
You have just saved my life (... time...) with you code !
THANK YOU !!!
Any help is appreciated .thanks !
The rest of the code makes sense to me (used to VBA in Excel) but I can't figure out why you need to execute another piece of code here.
Thanks for the great tool though.
I am new to the whole VBA thing and I Love love love this code!
I have 5000+ docs to review and if this works it will save heaps of time!
I have the code above running however i can see that it does not cater for replacing text in footers, Only headers and the body of the doc.
Can anyone assist in extending this to the entire document.
P.S. not sure if this is relevant but the list of words that i need to replace is the same for headers, footers and the body...
Any help would really be appreciated!