Copying Data from Multiple Workbooks to a Single Master File (Tab)

[eisf0r]

Hi All,

Thanks for your assistance. I'm looking to copy and paste data from multiple workbooks (with the same sheet name being "data upload" to a single "Master sheet".
I have about 160+ workbooks each with the same tab ("Data Upload") and I am trying to aggregate them all into one singular sheet, pasting as values.

I require to copy cells A2:PXXX (the last row) from the same named worksheet, but different workbooks being "Data Upload" into the "Master" sheet. I also require the data to be pasted below the previous data as to not override. In the end, I am hoping for all the data in the "Data Upload" tabs of all 160+ workbooks to be in a singular sheet ready for upload. It would be great if it could also be pasted as values. Please note that all files including the "master file" are contained in the same folder designated "Steve" below.

I have been doing some searching around and I have found the code below and have attempted to understand it and modify it for my needs.

When I run the code, I obtain a pop-up box selecting the folder destination, however when I click on "open" and "okay". I receive a runtime-error-9 which seems to relate to the copy area of the array. I am unsure how to solve this.

Could you please have a look at the code below or assist with an alternative for the solution above? Additionally, I am quite new to VBA (any references to learning material for newbies would also be appreciated).

Thanks!

Sub LoopAllExcelFilesInFolder()

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them


Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim ws2 As Worksheet
Dim y As Workbook

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "C:\Users\Desktop\Steve"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

Set y = Workbooks.Open("C:\Users\Desktop\Steve\ForecastData")
Set ws2 = y.Sheets("Master")

'Loop through each Excel file in folder
Do While myFile <> ""
    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Copy data on "Data Upload" sheet to "Master" Sheet in other workbook
    With wb.Sheets("Data Upload")
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A2:P" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2)
    End With

    wb.Close SaveChanges:=True
    'Get next file name
    myFile = Dir
Loop

'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[Flaiban]

Try this code :

Option Explicit
Const Ttrows = 1048576

Private sub Btexecut_click ' button name

Dim W as Worksheet
Dim  Sht as Worksheet
Dim Wnew as workbook
Dim ArcToOpen as Variant
Dim A as Integer
Dim ArchiveName as String

ArcToOpen = application.getopenfilename("Import Archive (*.xls*), *.xls*", Title:="Choose Archives", Multiselect:=True)

If not IsArray (ArcToOpen) Then
      
If ArcToOpen = "" or ArcToOpen = false then
msgbox "Annulled Process. File not Selected !"
Exit Sub
End If

End If

Application.ScreenUpDating = false

Set W = sheets("Sheet1")

W.Select
W.UsedRange.EntireColumn.Delete

For A = lbound(ArcToOpen) to ubound(ArcToOpen)

ArchiveName = ArcToOpen(A)
Application.Workbooks.Open ArcToOpen(A)
     
Set Wnew = ActiveWorkbook

for each Sht in Wnew.sheets

Sht.select
Sht.range("A1").currentregion.select

selection.copy destination:=w.cells(Ttrows,1).end(xlup).offset(1,0)

 Next sht

Application.DisplayAlerts = false

wnew.close savechanges:=false

Application.DisplayAlerts = true

w.cells(Ttrows,1).end(xlup).offset(1,0).select

Next

Application.ScreenUpDating = true

msgbox "Process completed successfully."

End Sub

 

[eisf0r]

Hi Flaiban,

Thanks for your help. When I select the file however I'm still getting error 9 - subscript out of range.

 

[Flaiban]

I changed the formula . See if it suits :

Option Explicit
Const Ttrows = 1048576

Private Sub Btexecut_click() ' button name

Application.ScreenUpdating = False

Dim W As Worksheet
Dim Sht As Worksheet
Dim Wnew As Workbook
Dim ArcToOpen As Variant
Dim A As Integer
Dim ArchiveName As String
Dim LastCel As Range


ArcToOpen = Application.GetOpenFilename("Import Archive (*.xls*), *.xls*", Title:="Choose Archives", MultiSelect:=True)

    If Not IsArray(ArcToOpen) Then
      
        If ArcToOpen = "" Or ArcToOpen = False Then
        MsgBox "Annulled Process. File not Selected !"
        Application.ScreenUpdating = True
        Exit Sub
        End If

    End If

Application.ScreenUpdating = False

Set W = Sheets("Sheet1")


W.UsedRange.EntireColumn.Delete
W.Select

For A = LBound(ArcToOpen) To UBound(ArcToOpen)

        ArchiveName = ArcToOpen(A)
        Application.Workbooks.Open (ArchiveName)
     
    Set Wnew = ActiveWorkbook

        For Each Sht In Wnew.Sheets

            Sht.Select
            Set LastCel = Sht.Cells(Ttrows, 1).End(xlUp)
            Sht.Range("A2", Sht.Cells(LastCel.Row, LastCel.End(xlToRight).Column)).Select ' without Hearders , otherwise change to "A1" .
            Selection.Copy Destination:=W.Cells(Ttrows, 1).End(xlUp).Offset(1, 0)
            

            Next Sht

    Application.DisplayAlerts = False

        ActiveWorkbook.Close savechanges:=False

    Application.DisplayAlerts = True

    W.Cells(Ttrows, 1).End(xlUp).Offset(1, 0).Select
    W.UsedRange.EntireColumn.AutoFit
    

Next A

Application.ScreenUpdating = True

MsgBox "Process completed successfully."

Set W = Nothing
Set LastCel = Nothing
Set Wnew = Nothing
Set Sht = Nothing

End Sub