Skip to content

Instantly share code, notes, and snippets.

@teocomi
Last active June 20, 2018 11:07
Show Gist options
  • Save teocomi/07991454b12930d9f53ea565d2853b7d to your computer and use it in GitHub Desktop.
Save teocomi/07991454b12930d9f53ea565d2853b7d to your computer and use it in GitHub Desktop.
Public Sub BatchReplaceTextInWordFiles()
' https://www.datanumen.com/blogs/find-replace-contents-multiple-word-documents/
Dim objDoc As Workbook
Dim strFile As String
Dim strFolder As String
Dim oldNamesFile As String
Dim newNamesFile As String
Dim strFindText As String
Dim strReplaceText As String
Dim oldnames As New Collection
Dim newnames As New Collection
strFolder = "FOLDER PATH"
oldNamesFile = "OLD NAMES PATH.txt"
newNamesFile = "NEW NAMES PATH.txt"
strFile = Dir(strFolder & "\" & "*.xlsx", vbNormal)
Dim FileNum As Integer
Dim DataLine As String
FileNum = FreeFile()
Open oldNamesFile For Input As #FileNum
While Not EOF(FileNum)
Line Input #FileNum, DataLine
oldnames.Add DataLine
Wend
FileNum = FreeFile()
Open newNamesFile For Input As #FileNum
While Not EOF(FileNum)
Line Input #FileNum, DataLine
newnames.Add DataLine
Wend
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
' Open each file in the folder to search and replace texts. Save and close the file after the action.
While strFile <> ""
Set objDoc = Workbooks.Open(Filename:=strFolder & "\" & strFile)
With objDoc
For L = 1 To objDoc.Worksheets.Count
objDoc.Worksheets(L).Activate
For I = 1 To oldnames.Count
objDoc.Worksheets(L).Cells.Replace _
What:=oldnames(I), Replacement:=newnames(I), _
SearchOrder:=xlByColumns, MatchCase:=False
Next
Next L
objDoc.Save
objDoc.Close
strFile = Dir()
End With
Wend
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
End Sub
Public Sub BatchReplaceTextInWordFiles()
' adapted from https://www.datanumen.com/blogs/find-replace-contents-multiple-word-documents/
Dim objDoc As Document
Dim strFile As String
Dim strFolder As String
Dim oldNamesFile As String
Dim newNamesFile As String
Dim strFindText As String
Dim strReplaceText As String
Dim oldnames As New Collection
Dim newnames As New Collection
strFolder = "FOLDER PATH"
oldNamesFile = "OLD NAMES PATH.txt"
newNamesFile = "NEW NAMES PATH.txt"
strFile = Dir(strFolder & "\" & "*.doc*", vbNormal)
Dim FileNum As Integer
Dim DataLine As String
' collect old names
FileNum = FreeFile()
Open oldNamesFile For Input As #FileNum
While Not EOF(FileNum)
Line Input #FileNum, DataLine
oldnames.Add DataLine
Wend
' collect new names
FileNum = FreeFile()
Open newNamesFile For Input As #FileNum
While Not EOF(FileNum)
Line Input #FileNum, DataLine
newnames.Add DataLine
Wend
' Open each file in the folder to search and replace texts. Save and close the file after the action.
While strFile <> ""
Set objDoc = Documents.Open(FileName:=strFolder & "\" & strFile)
With objDoc
With Selection
.HomeKey Unit:=wdStory
For i = 1 To oldnames.Count
With Selection.Find
.Text = oldnames(i)
.Replacement.Text = newnames(i)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
End With
objDoc.Save
objDoc.Close
strFile = Dir()
End With
Wend
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment