[英]Copying Data from Multiple Worksheets in Workbooks to Differing Worksheets in Separate Workbook - VBA Excel
I have found varying solutions online to this, but haven't been able to conform them to what I want. 我在网上找到了各种各样的解决方案,但是还无法使它们符合我的需求。 Here is the problem set: 这是问题集:
Open all .xlsx files in selected folder DONE 打开DONE所选文件夹中的所有文件的.xlsx
Copy Master Workbook to Archive folder (selected folder path/Archive) DONE 将主工作簿复制到存档文件夹(选定的文件夹路径/存档) 完成
Clear data in Master Workbook in Worksheet titled "FY19 Source" (Worksheet 3) from Row 2 and below. 从第2行及以下的工作表中的标题为“ FY19源”(工作表3)的主工作簿中清除数据。 DONE 完成
Clear data in Master Workbook in Worksheet titled "Travel-Events Calendar" (Worksheet 4) from Row 2 and below. 从第2行及以下行清除工作表中主工作簿中标题为“旅行事件日历”(工作表4)的数据。 DONE 完成
Clear data in Master Workbook in Worksheet titled "Transfer" (Worksheet 5) from Row 5 and below. 从第5行及以下行清除工作表中主工作簿中标题为“传输”(工作表5)的数据。 DONE 完成
For each open Workbook (except Master Workbook), copy the non-hidden/non-null data from all rows south of A2:M2 in Worksheets titled "FY19 Source" 对于每个打开的工作簿(主工作簿除外),从工作表标题为“ FY19源”的A2:M2以南的所有行中复制非隐藏/非空数据。
Paste data continuously in Master Workbook's "FY19 Source" Worksheet starting on Row 2. 从第2行开始,将数据连续粘贴到Master Workbook的“ FY19源”工作表中。
For each open Workbook, if they have a Worksheet labeled "Transfer" OR "Transfer2" OR "Transfer 3", copy the non-hidden/non-null data from all rows south of A2:M2 for each. 对于每个打开的工作簿,如果它们都有标记为“ Transfer”或“ Transfer2”或“ Transfer 3”的工作表,则从A2:M2以南的所有行中复制非隐藏/非空数据。
Paste data continuously in Master Workbooks "Transfer" Worksheet starting on Row 2 从第2行开始将数据连续粘贴到主工作簿“传输”工作表中
For each open Workbook clear filters from the Worksheets titled "Travel-Events Calendar" 对于每个打开的工作簿,请清除工作表中标题为“旅行事件日历”的过滤器
For each open Workbook (except Master Workbook), copy the non-hidden/non-null data from all rows south of A5:L5 对于每个打开的工作簿(主工作簿除外),从A5:L5以南的所有行中复制非隐藏/非空数据
Paste data continuously in Master Workbooks "Travel-Events Calendar" Worksheet starting on Row 5. 从第5行开始,将数据连续粘贴到主工作簿“旅行事件日历”工作表中。
Execute Refresh Links in Master Workbooks DONE 在完成的主工作簿中执行刷新链接
I could really use help with the copying/combining aspect of this from open workbooks as noted above. 如上所述,我真的可以在打开的工作簿中使用有关复制/合并方面的帮助。
I have found a couple of like-minded questions during my research but can't seem to apply them totally to this which is really frustrating :( It seems like I can do most of these steps in turn but I can't put anything together that works! Any guidance would be extremely appreciated. Thank you! 我在研究过程中发现了几个志同道合的问题,但似乎无法将它们完全应用到这个问题上,这真的很令人沮丧:(似乎我可以依次执行大多数这些步骤,但是我无法将所有内容组合在一起可以的,任何指导将不胜感激,谢谢!
Code I have so far annotated: 到目前为止,我已注释的代码:
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
DATA PROCESSING 数据处理
Dim wsCopy_F19 As Long
Dim wsCopy_Transfer As Long
Dim wsCopy_Travel As Long
Dim wsCopy As Worksheet
Dim numWs As Double
Dim i As Double
Dim wsCopyName As String
Dim Target1 As Range
Dim Target2 As Range
Dim Target3 As Range
numWs = wbCopy.Worksheets.Count
For i = 0 To numWs
wsCopy = wbCopy.Worksheets(i)
wsCopyName = wsCopy.Name
If wsCopyName = "FY19 Source" Then
wsCopy_F19 = wsCopy.Cells(Rows.Count, 1).End(xlUp).Row
Set Target1 = wsCopy.Range("A2:M" & wsCopy_F19)
Target1.Copy Destination:=wsMSTR_XXF19.Range("A" & rowMSTR_F19).PasteSpecial(xlPasteValues)
rowMSTR_F19 = wsMSTR_XXF19.Cells(Rows.Count, 1).End(xlUp).Row + 1
ElseIf InStr(wsCopyName, "Transfer") > 0 Then
wsCopy_Transfer = wsCopy.Cells(Rows.Count, 1).End(xlUp).Row
Set Target2 = wsCopy.Range("A2:M" & wsCopy_Transfer)
Target2.Copy Destination:=wsMSTR_Transfer.Range("A" & rowMSTR_Transfer).PasteSpecial(xlPasteValues)
rowMSTR_Transfer = wsMSTR_Transfer.Cells(Rows.Count, 1).End(xlUp).Row + 1
ElseIf wsCopyName = "Travel-Events Calendar" Then
wsCopy_Travel = wsCopy.Cells(Rows.Count, 1).End(xlUp).Row
Set Target3 = wsCopy.Range("A2:M" & wsCopy_Travel)
Target3.Copy Destination:=wsMSTR_Travel.Range("A" & rowMSTR_Travel).PasteSpecial(xlPasteValues)
rowMSTR_Travel = wsMSTR_Travel.Cells(Rows.Count, 1).End(xlUp).Row + 1
Else
End If
Next
Posting my solution below. 在下面发布我的解决方案。 The issue I had stemmed from not setting the object variable wsCopy = wbCopy.Worksheets(i)
. 我因未设置对象变量wsCopy = wbCopy.Worksheets(i)
。 It should have been Set wsCopy = wbCopy.Worksheets(i)
. 应该Set wsCopy = wbCopy.Worksheets(i)
。
Here is the Master Sub and Global Declarations 这是主子声明和全局声明
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
Here is the data processing 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
Big thanks to @Wookies-Will-Code for their invaluable help. 非常感谢@ Wookies-Will-Code的宝贵帮助。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.