Размещение моего решения ниже.Проблема, с которой я столкнулся, не состояла в установке переменной объекта wsCopy = wbCopy.Worksheets(i).Это должно было быть Set wsCopy = wbCopy.Worksheets(i).
Вот основная подпрограмма и глобальные объявления
Option Explicit
'These are Global to this MODULE, no need to pass to Subs
Dim wbMSTR As Workbook
Dim wsMSTR_XXF19 As Worksheet
Dim wsMSTR_Transfer As Worksheet
Dim wsMSTR_Travel As Worksheet
'You will increment the rows in your procedure
Dim rowMSTR_F19 As Long
Dim rowMSTR_Transfer As Long
Dim rowMSTR_Travel As Long
Sub MasterWorkbookCompile()
'Declaring Variables
Dim myPath As String
Dim archivePath As String
Dim fName As String
Dim wbCopy As Workbook
'Initialize
Set wbMSTR = ThisWorkbook
Set wsMSTR_XXF19 = wbMSTR.Worksheets("XX FY19 Source")
Set wsMSTR_Transfer = wbMSTR.Worksheets("Transfer Funds")
Set wsMSTR_Travel = wbMSTR.Worksheets("Travel-Events Calendar")
fName = Dir(Application.ThisWorkbook.FullName)
myPath = Application.ThisWorkbook.FullName
archivePath = "C:\XXXX\" & (fName) 'Change to folder for archive subfolder
'Set your Master data rows HERE
rowMSTR_F19 = 2
rowMSTR_Transfer = 2
rowMSTR_Travel = 5
'Debug.Print myPath, archivePath
'****** TURNED THIS OFF FOR TESTING *******
'Saving current file to archive folder
ThisWorkbook.SaveCopyAs Filename:=archivePath
'Unfilters data on last worksheet
On Error Resume Next
wsMSTR_Travel.ListObjects("Table2").AutoFilter.ShowAllData
'Clearing data in relevant worksheets
wsMSTR_XXF19.Range(wsMSTR_XXF19.Range("A2:M2"), wsMSTR_XXF19.Range("A2:M2").End(xlDown)).ClearContents
wsMSTR_Transfer.Range(wsMSTR_Transfer.Range("A2:M2"), wsMSTR_Transfer.Range("A2:M2").End(xlDown)).ClearContents
With wsMSTR_Travel.ListObjects("Table2")
.Range.AutoFilter
.DataBodyRange.Offset(1).Resize(.DataBodyRange.Rows.Count - 1, .DataBodyRange.Columns.Count).Rows.ClearContents
.DataBodyRange.Rows(1).SpecialCells(xlCellTypeConstants).ClearContents
End With
On Error GoTo 0
'Opens all .xlsx files
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDialog
.AllowMultiSelect = False
.Title = "Select a folder"
.InitialFileName = "C:\Users\XXX" 'to be set to initial folder selection path
If .Show <> -1 Then GoTo NextCode
xStrPath = .SelectedItems(1) & "\"
End With
'Handle Cancel
NextCode:
xStrPath = xStrPath
If xStrPath = "" Then GoTo LeaveCode
xFile = Dir(xStrPath & "*.xls*")
'Make work fast, shut off some items, no screen flicker, kill clipboard alert
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Disables all macros in newly opened files
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Do While xFile <> ""
'Set up your event code here, get the Workbook
Set wbCopy = Workbooks.Open(Filename:=xStrPath & xFile, UpdateLinks:=0)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'***********************************
' PERFORM ACTIONS ON THIS COPYBOOK SHEETS HERE
'***********************************
Call processData(wbCopy)
'Save and Close the COPY Workbook
wbCopy.Close SaveChanges:=False
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get Next File to Process
xFile = Dir
Loop
'Delete empty rows in Travel Sheet
Call DeleteEmptyRows(wbCopy)
'Message Box when tasks are completed
MsgBox "Master Update Complete"
LeaveCode:
'Turn things back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
'Refreshes all PivotTable and PivotGraph Links
wbMSTR.RefreshAll
End Sub
Вот подпрограмма обработки данных:
'Handle your data transfer here, it will be cleaner
'the same workbook variable name is used here in the args
'it doesn't have to be named the same, it is a pointer to the actual object ByRef
Public Sub processData(ByRef wbCopy As Workbook)
'***** GLOBAL TO MODULE *****
'These are Global to this MODULE, no need to pass to Subs
'Dim wbMSTR As Workbook
'Dim wsMSTR_XXF19 As Worksheet
'Dim wsMSTR_Transfer As Worksheet
'Dim wsMSTR_Travel As Worksheet
'You will increment the rows
'Dim rowMSTR_F19 As Long
'Dim rowMSTR_Transfer As Long
'Dim rowMSTR_Travel As Long
'***** GLOBAL TO MODULE *****
'Defining our variables as the relevant Worksheet locations we want to copy
Dim wsCopy_F19 As Long
Dim wsCopy_Transfer As Long
Dim wsCopy_Travel As Long
Dim wsCopy_XXX2 As Long
Dim wsCopy_XXX1 As Long
'This is the Worksheet we will target and its name
Dim wsCopy As Worksheet
Dim wsCopyName As String
'Variables related to looping through Worksheets in Workbook
Dim numWs As Double
Dim i As Double
'Target copy range
Dim Target1 As Range
Dim Target2 As Range
Dim Target3 As Range
Dim Target4 As Range
Dim Target5 As Range
'Gets the number of Worksheets in the Workbook
numWs = wbCopy.Worksheets.Count
'For worksheets 1 to the final number... do the below
For i = 1 To numWs
With wbCopy
Set wsCopy = wbCopy.Worksheets(i)
wsCopyName = wsCopy.Name
If wsCopyName = "A 19 Source" Or wsCopyName = "B 19 Source" Or wsCopyName = "C FY19 Source" Or wsCopyName = "D FY19 Source" Or wsCopyName = "E FY19 Source" Or wsCopyName = "F 19 Source" Or wsCopyName = "G FY19 Source" Or wsCopyName = "H FY19 Source" Then
wsCopy_F19 = wsCopy.Cells(Rows.Count, 1).End(xlUp).Row
Set Target1 = wsCopy.Range("A2:M" & wsCopy_F19)
Target1.Copy
wsMSTR_XXF19.Range("A" & rowMSTR_F19).PasteSpecial Paste:=xlValues
rowMSTR_F19 = wsMSTR_XXF19.Cells(Rows.Count, 1).End(xlUp).Row + 1
ElseIf wsCopyName = "XXX3 FY19 Source" Then
wsCopy_Transfer = wsCopy.Cells(Rows.Count, 1).End(xlUp).Row
Set Target2 = wsCopy.Range("A2:M" & wsCopy_Transfer)
Target2.Copy
wsMSTR_Transfer.Range("A" & rowMSTR_Transfer).PasteSpecial Paste:=xlValues
rowMSTR_Transfer = wsMSTR_Transfer.Cells(Rows.Count, 1).End(xlUp).Row + 1
' **************************************************************************************************************
''THIS IS COMMENTED OUT BECAUSE THERE IS NO XXX2 FUNDING - COMMENT BACK IN IF FUNDING OCCURS''
' **************************************************************************************************************
' ElseIf wsCopyName = "XXX2" Then
' wsCopy_XXX2 = wsCopy.Cells(Rows.Count, 1).End(xlUp).Row
' Set Target4 = wsCopy.Range("A2:M" & wsCopy_XXX2)
' Target4.Copy
' wsMSTR_Transfer.Range("A" & rowMSTR_Transfer).PasteSpecial Paste:=xlValues
' rowMSTR_Transfer = wsMSTR_Transfer.Cells(Rows.Count, 1).End(xlUp).Row + 1
' **************************************************************************************************************
''THIS IS COMMENTED OUT BECAUSE THERE IS NO XXX1 FUNDING - COMMENT BACK IN IF FUNDING OCCURS''
' **************************************************************************************************************
' ElseIf wsCopyName = "ENTER XXX1 FUNDING SHEET NAME" Then
' wsCopy_XXX1 = wsCopy.Cells(Rows.Count, 1).End(xlUp).Row
' Set Target5 = wsCopy.Range("A2:M" & wsCopy_XXX1)
' Target5.Copy
' wsMSTR_Transfer.Range("A" & rowMSTR_Transfer).PasteSpecial Paste:=xlValues
' rowMSTR_Transfer = wsMSTR_Transfer.Cells(Rows.Count, 1).End(xlUp).Row + 1
ElseIf wsCopyName = "Travel-Events Calendar" Or wsCopyName = "Travel - Events Calendar" Then
wsCopy_Travel = wsCopy.Cells(Rows.Count, 1).End(xlUp).Row
wsCopy.ListObjects(1).AutoFilter.ShowAllData
Set Target3 = wsCopy.Range("A5:L" & wsCopy_Travel)
Target3.Copy
wsMSTR_Travel.Range("A" & rowMSTR_Travel).PasteSpecial Paste:=xlValues
rowMSTR_Travel = wsMSTR_Travel.Cells(Rows.Count, 1).End(xlUp).Row + 1
Else
End If
End With
Next
End Sub
Большое спасибо@ Wookies-Will-Code за неоценимую помощь.