#1
|
|||
|
|||
Calling macro from loop-all-files macro only opens one file
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 |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Calling a macro from a template using OnAction | sg11 | Word VBA | 2 | 04-30-2018 11:43 PM |
Macro to open Multiple files and copy information to a master file | gbaker | Excel Programming | 2 | 04-08-2016 08:44 AM |
Macro Loop Help | Twizzle008 | Word VBA | 15 | 09-18-2015 03:20 PM |
Compare files in different directories, slightly different namesm, Macro doesn't loop | lkpederson | Word VBA | 0 | 04-28-2015 01:32 PM |
Calling a macro in powerpoint from command line | SeattleITguy | PowerPoint | 4 | 11-26-2014 01:41 AM |