Technical Level: Basic +
Summary: There are occasions when the identical Find and Replace edit is required to be made in multiple documents, or Style changes, or Tracked Change edits, et cetera. To do this, a macro is required, and if you search the web you might find a few solutions that you can try. However, most were created for earlier versions of Word and none run cross-platform (PC and Mac) without major alteration. The solution provided here runs with Mac Office 2016 and 2011 and all versions of Windows Office from 2016 back to 2007. It is also just the critical first part of the overall macro solution that you will need to apply your uniquely batched edits.
Details:
The macro provided is fully self-contained, it automatically determines the platform (PC or Mac) where it is running and then uses the proper methods for finding and opening the documents.
The routine can be used to open just one document, or almost an unlimited number of documents … the limitation is just how many files you want to include in the batch. You select the files from the File Explorer/Finder dialog that opens first.
The following is the VBA code that performs the cross-platform file handling. I have not included a Macro Procedure Sub Name or End Sub statement, I expect that you will be pasting this code into your own uniquely named subroutine.
An acknowledgement is made to the Ron de Bruin Excel Automation website for tips and script related to AppleScript, a.k.a. MacScript in VBA (Visual Basic for Applications) jargon. [Moderator note: see Excel for Windows Tips (archive) for archive of Ron de Bruin's excellent information.]
'Written by Richard V. Michaels, Office Apps and Services MVP
'http://www.greatcirclelearning.com
'Browse for files to update
Dim i As Integer, selFiles() As String
Dim strFolderPath As String, Sep As String
Sep = Application.PathSeparator
Erase selFiles
#If Mac Then
Dim iPath As String, iScript As String, iFiles As String
Dim iSplit As Variant, N As Long, FileFormat As String
FileFormat = "{""org.openxmlformats.wordprocessingml.document"",""com.microsoft.word.doc""," & _
"""org.openxmlformats.wordprocessingml.document.macroenabled""}"
On Error Resume Next
iPath = MacScript("return (path to documents folder) as String")
If Application.Version < 15 Then
'Mac Office 2011
iScript = "set applescript's text item delimiters to {ASCII character 10} " & vbNewLine & _
"set theFiles to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Select the files to update"" default location alias """ & _
iPath & """ with multiple selections allowed) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
Else
'Mac Office 2016
iScript = "set theFiles to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Select the files to update"" default location alias """ & _
iPath & """ with multiple selections allowed)" & vbNewLine & _
"set thePOSIXFiles to {}" & vbNewLine & _
"repeat with aFile in theFiles" & vbNewLine & _
"set end of thePOSIXFiles to POSIX path of aFile" & vbNewLine & _
"end repeat" & vbNewLine & _
"set {TID, text item delimiters} to {text item delimiters, ASCII character 10}" & vbNewLine & _
"set thePOSIXFiles to thePOSIXFiles as text" & vbNewLine & _
"set text item delimiters to TID" & vbNewLine & _
"return thePOSIXFiles"
End If
iFiles = MacScript(iScript)
On Error GoTo 0
If iFiles <> "" Then
iSplit = Split(iFiles, Chr(10))
ReDim Preserve selFiles(UBound(iSplit))
strFolderPath = Left(iSplit(0), InStrRev(iSplit(0), Sep))
For N = LBound(iSplit) To UBound(iSplit)
selFiles(N) = iSplit(N)
Next N
Else
Exit Sub
End If
#Else
'Windows Office 2016, 2013, 2010, 2007
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select the files to update"
.InitialFileName = curDir
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "All Word Files", "*.docx; *.docm; *.doc", 1
If .Show = 0 Then
Exit Sub
End If
ReDim Preserve selFiles(.SelectedItems.Count - 1)
strFolderPath = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), Sep))
For i = 0 To .SelectedItems.Count - 1
selFiles(i) = .SelectedItems(i + 1)
Next
.Filters.Clear
End With
#End If
Dim doc As word.Document, FirstTime As Boolean
FirstTime = True
On Error GoTo errHandler
For i = 0 To UBound(selFiles)
'The following is setup to perform a conditional first time check
'Depending on your exact requirements, you may not need it.
If FirstTime = True Then
Set doc = Documents.Open(FileName:=selFiles(i))
'This is where you will insert your code for applying the edits
'you want to perform
doc.Save
DoEvents
FirstTime = False
Else
On Error GoTo 0
Set doc = Documents.Open(FileName:=selFiles(i))
'This is where you will insert your code for replicating the edits
'you made to the first document
doc.Close word.WdSaveOptions.wdSaveChanges
DoEvents
End If
Next
MsgBox "Update Complete. Your original document remains open.", vbInformation, "Success"
errHandler:
If Err.Number <> 0 Then
MsgBox Err.Description, vbExclamation, "Uh-Oh!"
End If