Calling macro from loop-all-files macro only opens one file

[Peterson]

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:

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