I want to start by expressing my appreciation for macropod and Greg Maxey for all of the code and guidance you've put out there on the Internet over the years. If you're reading this, you'll soon see that what follows is almost entirely yours. Thank you.
I found code that macropod and Greg created to get find/replace terms from an Excel file and search in Word. I've modified it a bit so it now goes through all stories. This works fine.
The problem is, I'm now trying to call the macro from a folder-picker/loop-all-files macro that I've been using for several years without issue. But after the first file closes, the macro ends. I suspect that it has something to do with the fact that there is user input while the file is open, because all of the macros I've ever run before open/do stuff/close automatically, but I don't know...
I'm attaching a zip with test files, in case the problem isn't immediately apparent here:
Code:
Sub LoopAllWordFilesInFolder_ForBulkFind() ' 03/27/2021
Dim docDocument As Document
Dim strPath As String
Dim StrFile As String
Dim strExtension As String
Dim FolderPicker As FileDialog
Application.ScreenUpdating = False
' Get target folder path from user:
Set FolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FolderPicker
.Title = "Choose the folder containing your files"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
strPath = .SelectedItems(1) & "\"
End With
' In case the user cancels
NextCode:
strPath = strPath
If strPath = "" Then GoTo ResetSettings
' Word files only:
strExtension = "*.doc*"
' Target path with file extension:
StrFile = Dir(strPath & strExtension)
' Loop through each file in the folder:
Do While StrFile <> ""
' Set variable equal to opened document
Set docDocument = Documents.Open(Filename:=strPath & StrFile)
DoEvents
' ##### CALL MACRO(S) HERE #####
Call Find_BulkFindReplace
' Save and close:
docDocument.Close SaveChanges:=True
' Ensure document has closed before moving on to next line of code:
DoEvents
' Get next file name:
StrFile = Dir
Loop
MsgBox "The macro has looped through the files in the folder you chose and completed the tasks."
ResetSettings:
Application.ScreenUpdating = True
End Sub
Sub Find_BulkFindReplace() ' 03/26/2021
' This macro loads a list of find-and-replace terms from an Excel file, then
' searches each one in Word, prompting the user to replace or skip each found
' word. (The macro can be modified to automatically replace the terms.)
' The macro searches the main body, all headers/footers, text boxes, and shapes.
' Sources:
' Main code:
' http://www.vbaexpress.com/forum/showthread.php?42897-Macro-for-replacing-EXCEL-data-into-WORD/page2
' Paul Edstein (macropod) and Greg Maxey
' Search all stories:
' https://gregmaxey.com/word_tip_pages/using_a_macro_to_replace_text_wherever_it_appears_in_a_document.html
Dim arrList
Dim lngIndex As Long
Dim strWBName As String
' For looping through stories:
Dim rngStory As Word.range
Dim lngValidate As Long
' For looping through stories, fix the skipped blank Header/Footer problem:
lngValidate = ActiveDocument.Sections(1).Headers(1).range.StoryType
''strWBName = "C:\Temp\Find-Replace List.xlsx"
strWBName = ActiveDocument.Path & "\Find-Replace List.xlsx"
If Dir(strWBName) = "" Then
MsgBox "Word list not found." & vbCr & vbCr & "The file name must be ""Find-Replace List.xlsx"" and it must be saved in the same folder as the Word file(s).", vbExclamation
Exit Sub
End If
If fcnIsFileLocked(strWBName) Then
If MsgBox("The Excel file containing the list of find/replace terms is open." & vbCr + vbCr _
& "Save and close the Excel file, then re-run the macro." _
, vbExclamation + vbOKOnly, "Save and Close the Excel File") = vbOK Then
Exit Sub
End If
End If
arrList = fcnExcelDataToArray(strWBName)
Application.ScreenUpdating = True
' Loop through all story types in the current document:
For Each rngStory In ActiveDocument.StoryRanges
' Loop through all linked stories:
Do
If IsArray(arrList) Then
For lngIndex = 0 To UBound(arrList, 2)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = arrList(0, lngIndex)
'To automatically replace found terms, uncomment the following two lines _
and comment out all lines from While through Wend that follow:
'.Replacement.Text = arrList(1, lngIndex)
'.Execute Replace:=wdReplaceAll
'For user prompt and manual replacement, comment out previous
'two lines and use the following While loop:
While .Execute
With rngStory
.Duplicate.Select
Select Case MsgBox("Replace this instance of: " & arrList(0, lngIndex) _
& vbCr & "with: " & arrList(1, lngIndex) & "?", vbYesNoCancel + vbQuestion, "Replace?")
Case vbYes: .Text = arrList(1, lngIndex)
Case vbCancel: Exit Sub
End Select
.Collapse wdCollapseEnd
End With
Wend
End With
Next
Else
MsgBox "A connection was not available to the Excel file."
End If
' Get next linked story (if any):
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
' Set view to Print Layout -- the macro ends in a two-pane Draf:
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
With ActiveWindow
' The second pane must be closed:
.Panes(2).Close
' ...but if you were to skip the prior step and go right to
' Page Layout view, the focus will remain in the footer.
.View.Type = wdPrintView
End With
End If
' Put cursor at beginning of document; otherwise, when the macro
' ends, one of the found words remains selected:
Selection.HomeKey Unit:=wdStory
Application.ScreenUpdating = True
lbl_Exit:
Exit Sub
End Sub
Private Function fcnExcelDataToArray(strWorkbook As String, _
Optional strRange As String = "Sheet1", _
Optional bIsSheet As Boolean = True, _
Optional bHeaderRow As Boolean = True) As Variant ' 03/26/2021
'Default parameters include "Sheet1" as the named sheet, range of the full named sheet and a header row is used.
Dim oRS As Object, oConn As Object
Dim lngRows As Long
Dim strHeaderYES_NO As String
strHeaderYES_NO = "YES"
If Not bHeaderRow Then strHeaderYES_NO = "NO"
If bIsSheet Then strRange = strRange & "$]" Else strRange = strRange & "]"
Set oConn = CreateObject("ADODB.Connection")
oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
If oConn.State = 0 Then
oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.15.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
End If
If oConn.State = 1 Then
Set oRS = CreateObject("ADODB.Recordset")
oRS.Open "SELECT * FROM [" & strRange, oConn, 2, 1
With oRS
.MoveLast
lngRows = .RecordCount
.MoveFirst
End With
fcnExcelDataToArray = oRS.GetRows(lngRows)
Else
fcnExcelDataToArray = "~~NO CONNECTION AVAILABLE~~"
End If
lbl_Exit:
If oConn.State = 1 Then
oConn.Close
If oRS.State = 1 Then oRS.Close
Set oRS = Nothing
End If
Set oConn = Nothing
Exit Function
End Function
Function fcnIsFileLocked(strFileName As String) As Boolean ' 03/26/2021
On Error Resume Next
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
fcnIsFileLocked = Err.Number
Err.Clear
End Function