Copying Data from Multiple Worksheets in Workbooks to Differing Worksheets in Separate Workbook - VBA Excel

Question

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
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. DONE
Clear data in Master Workbook in Worksheet titled "Travel-Events Calendar" (Worksheet 4) from Row 2 and below. DONE
Clear data in Master Workbook in Worksheet titled "Transfer" (Worksheet 5) from Row 5 and below. 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"
Paste data continuously in Master Workbook's "FY19 Source" Worksheet starting on Row 2.
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.
Paste data continuously in Master Workbooks "Transfer" Worksheet starting on Row 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
Paste data continuously in Master Workbooks "Travel-Events Calendar" Worksheet starting on Row 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

You can't copy the file from disk because you have it open and running the code!. You could use saveas to save a copy, followed by a second saveas to re-point the open file to the original location — Harassed Dad
Thank you @HarassedDad, many thanks. Updated easily to ThisWorkbook.SaveCopyAs Filename:=archivePath. — dziegler
I guess I am not sure what your issues truly are, you simply need a method that processes each workbook you open based on worksheet Name, CodeName, or position in the workbook, Do your work (copies and Title changes) based on your worksheet conditions, then close the workbook, onto the next one. I do something similar to this with multiple workbooks and worksheets almost daily. But your method is unique to you, your data, and your naming conventions. Items 6-12 are just initiated from inside your Master Workbook, processing a directory the user chooses, it'll come together once you start. — Wookies-Will-Code
@Wookies-Will-Code I think that last sentiment is spot-on. Perhaps just having a hard time catching that first "thread" of code to point me in the right direction. — dziegler
Posted some code for you below, it is not done for you, but it should give you the framework to see this through. — Wookies-Will-Code

dziegler dziegler · Accepted Answer · 2019-07-02T16:10:53

Posting my solution below. The issue I had stemmed from not setting the object variable wsCopy = wbCopy.Worksheets(i). It should have been 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.

Copying Data from Multiple Worksheets in Workbooks to Differing Worksheets in Separate Workbook - VBA Excel

1 Answers