將數據從工作簿中的多個工作表復制到單獨工作簿中的不同工作表-VBA Excel

Question

我在網上找到了各種各樣的解決方案，但是還無法使它們符合我的需求。 這是問題集：

打開DONE所選文件夾中的所有文件的.xlsx
將主工作簿復制到存檔文件夾（選定的文件夾路徑/存檔）完成
從第2行及以下的工作表中的標題為“ FY19源”（工作表3）的主工作簿中清除數據。 完成
從第2行及以下行清除工作表中主工作簿中標題為“旅行事件日歷”（工作表4）的數據。 完成
從第5行及以下行清除工作表中主工作簿中標題為“傳輸”（工作表5）的數據。 完成
對於每個打開的工作簿（主工作簿除外），從工作表標題為“ FY19源”的A2：M2以南的所有行中復制非隱藏/非空數據。
從第2行開始，將數據連續粘貼到Master Workbook的“ FY19源”工作表中。
對於每個打開的工作簿，如果它們都有標記為“ Transfer”或“ Transfer2”或“ Transfer 3”的工作表，則從A2：M2以南的所有行中復制非隱藏/非空數據。
從第2行開始將數據連續粘貼到主工作簿“傳輸”工作表中
對於每個打開的工作簿，請清除工作表中標題為“旅行事件日歷”的過濾器
對於每個打開的工作簿（主工作簿除外），從A5：L5以南的所有行中復制非隱藏/非空數據
從第5行開始，將數據連續粘貼到主工作簿“旅行事件日歷”工作表中。
在完成的主工作簿中執行刷新鏈接

如上所述，我真的可以在打開的工作簿中使用有關復制/合並方面的幫助。

我在研究過程中發現了幾個志同道合的問題，但似乎無法將它們完全應用到這個問題上，這真的很令人沮喪：(似乎我可以依次執行大多數這些步驟，但是我無法將所有內容組合在一起可以的，任何指導將不勝感激，謝謝！

到目前為止，我已注釋的代碼：

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

數據處理

                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

Answer 1

在下面發布我的解決方案。 我因未設置對象變量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的寶貴幫助。

將數據從工作簿中的多個工作表復制到單獨工作簿中的不同工作表-VBA Excel

問題描述

1 個解決方案

解決方案1
0 已采納 2019-07-02 16:10:53

將數據從工作簿中的多個工作表復制到單獨工作簿中的不同工作表-VBA Excel

問題描述

1 個解決方案

解決方案1 0 已采納 2019-07-02 16:10:53

解決方案1
0 已采納 2019-07-02 16:10:53