我在网上找到了各种各样的解决方案，但是还无法使它们符合我的需求。这是问题集：
打开所选文件夹完成
将主工作簿复制到存档文件夹（选定的文件夹路径/存档）完成
清除工作表中标题为“ FY19源”（工作表3）的主工作簿中的数据（来自第2行及以下）。 完成
清除工作表中标题为“旅行事件日历”（工作表4）中第二行及以下行中的数据。 完成
在工作表的主工作簿中，清除第5行及以下行中标题为“ Transfer”（工作表5）的数据。 完成
对于每个打开的工作簿（主工作簿除外），从工作表标题为“ FY19源”的A2：M2以南的所有行中复制非隐藏/非空数据
从第2行开始在Master Workbook的“ FY19源”工作表中连续粘贴数据。
对于每个打开的工作簿，如果它们都有一个标记为“ Transfer”或“ Transfer2”或“ Transfer 3”的工作表，则为每个工作簿复制A2：M2以南所有行中的非隐藏/非空数据
从第2行开始将数据连续粘贴到主工作簿“传输”工作表中
对于每个打开的工作簿，清除工作表中标题为“旅行事件日历”的过滤器
对于每个打开的工作簿（“主工作簿”除外），从A5：L5以南的所有行中复制非隐藏/非空数据
从第5行开始，将数据连续粘贴到主工作簿“旅行事件日历”工作表中。
在主工作簿中执行刷新链接完成
如上所述，我真的可以从打开的工作簿中使用有关复制/合并方面的帮助。
我在研究过程中发现了几个志同道合的问题，但似乎无法将它们完全应用到这个问题上，这真的很令人沮丧:(看来我可以依次执行大多数这些步骤，但是我却不能将所有可行的东西放在一起！任何指导将不胜感激。谢谢！
我到目前为止已注释的代码：
"stream_context" => stream_context_create(
array(
'ssl' => array(
'verify_peer' => true,
'verify_peer_name' => true,
'crypto_method' => STREAM_CRYPTO_METHOD_TLSv1_2_CLIENT
)
)
)
数据处理
Sub MasterWorkbookCompile()
'Declaring Variables
Dim myPath As String
Dim archivePath As String
Dim endSourceSheet As Worksheet
Dim endTransferSheet As Worksheet
Dim endTravelSheet As Worksheet
fName = Dir(Application.ThisWorkbook.FullName)
myPath = Application.ThisWorkbook.FullName
archivePath = "C:\Users\XX\" & (fName)
'Debug.Print myPath, archivePath
'Saving current file to archive folder
ThisWorkbook.SaveCopyAs Filename:=archivePath
'Unfilters data on last worksheet
On Error Resume Next
ThisWorkbook.Worksheets("Travel-Events Calendar").ListObjects("Table2").AutoFilter.ShowAllData
'Clearing data in relevant worksheets
ThisWorkbook.Sheets("XXFY19 Source").Range(ThisWorkbook.Sheets("XXFY19 Source").Range("A2:M2"), ThisWorkbook.Sheets("XXFY19 Source").Range("A2:M2").End(xlDown)).ClearContents
ThisWorkbook.Sheets("Transfer Funds").Range(ThisWorkbook.Sheets("Transfer Funds").Range("A2:M2"), ThisWorkbook.Sheets("Transfer Funds").Range("A2:M2").End(xlDown)).ClearContents
With ThisWorkbook.Sheets("Travel-Events Calendar").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
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
xFileDialog.InitialFileName = "C:\Users\XX"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xFile = Dir(xStrPath & "\*.xlsx")
Do While xFile <> ""
If Not ActiveWorkbook Then
Workbooks.Open xStrPath & "\" & xFile
xFile = Dir
End If
Loop
'Refreshes any PivotTable Links
ThisWorkbook.RefreshAll
End Sub
答案 0 :(得分：0)
在下面发布我的解决方案。我的问题源于未设置对象变量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的宝贵帮助。