Copy worksheets from multiple workbooks into specific sheet in master

[JimLes]

Hello,
I am trying to use VBA to copy the entire contents (data) of "Sheet1" from multiple workbooks located under a single folder to a master workbook named Headcount Rollup Template. Each sheet should be imported to a specific tab in the master workbook.

I have set up a sheet within my master called "Tab Names" that contains the table I am referencing to map the file to the sheet tab name. It is set up like this:

Column A
Wbk Name
Active HC - US Data.xls
Active HC - UK Data.xls
Active HC - France Data.xls

Column B
Sht Name
US HC
UK HC
FRA HC

Example: all data in "Sheet1" in Active HC - US Data.xls should be copied to tab "US HC" in master workbook

I have been working with the code below but getting an "Object Required" error on this line: "Wbk.Sheets("Sheet1").Cells.Copy Destination:=sht.[A1]" when it runs.

Here is my current code that returns an object required error:

Sub ImportSheets()
Dim Path As String
Dim filename As String
Dim sht As Worksheet
Dim wkB As Workbook
Dim i As Integer
Dim r As Range
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Import the first worksheet for each file under R:\HC Data
Path = "R:\HR Ops Team Folders\Reporting & Analysis\Headcount\HC Data"
filename = Dir(Path & "\*.xls")
i = 1
Do While filename <> ""
For Each r In Worksheets("Tab Names").Range("A2:A9")
If r.Value = filename Then
'this assumes that the sheet name is in the next column
Set sht = ThisWorkbook.Sheets(r.Offset(0, 1).Value)
Exit For
End If
Next
Workbooks.Open filename:=Path & "\" & filename
If SheetExists("Sheet1") Then
Set wkB = ActiveWorkbook
Wbk.Sheets("Sheet1").Cells.Copy Destination:=sht.[A1]
'ActiveSheet.Name = "Sheet" & i
i = i + 1
wkB.Close savechanges:=False
Else
MsgBox "Sheets1 does not exist in file '" & filename & "'", vbExclamation, "ERROR !!"
ActiveWorkbook.Close savechanges:=False
End If
filename = Dir
Loop
Sheets("Tracking #").Select
MsgBox "All files have been imported successfully!"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

__________________________________________________ _________
Function SheetExists(ByVal sName As String)
Dim sht As Worksheet

SheetExists = True
For Each sht In ActiveWorkbook.Sheets
If sht.Name = sName Then Exit Function
Next sht

SheetExists = False
End Function


I am trying to get the code to loop through and map the file name to the tab name and copy the data in the tab location of the mast worksheet.

Any help is greatly appreciated!!

<!-- / message -->

 

[ravishankar]

Hi
Paste the following codes in the master workbook and save it in the same folder containing multiple workbooks. Run the macro. It adds sheets to master workbook, opens each file and copies sheet1 and pastes to master.
Ravi

Sub Jimles()
Dim z  As Long, e As Long, g As Long, h As Long
Dim f As String, m As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Sheet1").Select
Cells(1, 1) = "=cell(""filename"")"
Cells(1, 2) = "=left(A1,find(""["",A1)-1)"
Cells(2, 1).Select
f = Dir(Cells(1, 2) & "*.xls")
Do While Len(f) > 0
ActiveCell.Formula = f
ActiveCell.Offset(1, 0).Select
f = Dir()
Loop
z = Cells(Rows.Count, 1).End(xlUp).Row
For e = 2 To z
If Sheets("Sheet1").Cells(e, 1) <> ActiveWorkbook.Name Then
n = InStr(Sheets("Sheet1").Cells(e, 1), "-") + 1
m = Mid(Sheets("Sheet1").Cells(e, 1), n, n + 3) & " HC"
Sheets.Add.Name = m
Workbooks.Open filename:=Sheets("sheet1").Cells(e, 1)
Worksheets("Sheet1").UsedRange.Copy
ActiveWorkbook.Close False
Worksheets(m).Range("A1").PasteSpecial
End If
Next e
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "collating is complete."
End Sub

 

[JimLes]

Thanks, works great!!!

 

[malkaff]

I get error 400.. Any ideas why? Thanks.

Hi
Paste the following codes in the master workbook and save it in the same folder containing multiple workbooks. Run the macro. It adds sheets to master workbook, opens each file and copies sheet1 and pastes to master.
Ravi

Sub Jimles()
Dim z  As Long, e As Long, g As Long, h As Long
Dim f As String, m As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Sheet1").Select
Cells(1, 1) = "=cell(""filename"")"
Cells(1, 2) = "=left(A1,find(""["",A1)-1)"
Cells(2, 1).Select
f = Dir(Cells(1, 2) & "*.xls")
Do While Len(f) > 0
ActiveCell.Formula = f
ActiveCell.Offset(1, 0).Select
f = Dir()
Loop
z = Cells(Rows.Count, 1).End(xlUp).Row
For e = 2 To z
If Sheets("Sheet1").Cells(e, 1) <> ActiveWorkbook.Name Then
n = InStr(Sheets("Sheet1").Cells(e, 1), "-") + 1
m = Mid(Sheets("Sheet1").Cells(e, 1), n, n + 3) & " HC"
Sheets.Add.Name = m
Workbooks.Open filename:=Sheets("sheet1").Cells(e, 1)
Worksheets("Sheet1").UsedRange.Copy
ActiveWorkbook.Close False
Worksheets(m).Range("A1").PasteSpecial
End If
Next e
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "collating is complete."
End Sub

 

[excelbee2013]

Use the code below to and change values according to your need. Just out all files at a location like I have given "C:\Users\267009\Desktop\Das-<wbr style="font-family: arial, sans-serif;">rough work\New folder" and this code will simply open al files one by one and copy data from those files to your macro(master) file row by row.

[FONT=arial]Sub Macro1()[/FONT]
[FONT=arial]Dim MyFolder As String[/FONT]
[FONT=arial]Dim MyFile As String[/FONT]
[FONT=arial]MyFolder = "C:\Users\267009\Desktop\Das-[/FONT]<wbr style="font-family: arial, sans-serif;">[FONT=arial]rough work\New folder"  'Give complete path of your directory in which files are stored[/FONT]
[FONT=arial]MyFile = Dir(MyFolder & "\*.xls")[/FONT]
[FONT=arial]Dim i As Integer[/FONT]
[FONT=arial]i = 3 'give your row number in consolidate file where you want to paste data[/FONT]
[FONT=arial]Do While MyFile <> ""  'we will be running while loop to get data from each and every file[/FONT]
[FONT=arial]    Workbooks.Open Filename:=MyFolder & "\" & MyFile 'First we open file[/FONT]
[FONT=arial]    Windows(MyFile).Activate 'Now activete file[/FONT]
[FONT=arial]    Sheets(1).Activate 'activate the sheet number like 3 for your "assumption sheet"[/FONT]
[FONT=arial]    Range("A1:N62").Select 'give here range which you want to copy[/FONT]
[FONT=arial]    Selection.Copy[/FONT]
[FONT=arial]    Windows("consolidate.xlsm").[/FONT]<wbr style="font-family: arial, sans-serif;">[FONT=arial]Activate 'Now activate your  consolidate file[/FONT]
[FONT=arial]    Range("A" & i).Select 'Select range where you want to paste[/FONT]
[FONT=arial]    ActiveSheet.Paste[/FONT]
[FONT=arial]    Windows(MyFile).Activate 'again activate file to close it[/FONT]
[FONT=arial]    ActiveWorkbook.Close SaveChanges:=False 'close file as we have copied data from it[/FONT]
[FONT=arial]    MyFile = Dir[/FONT]
[FONT=arial]    i = i + 1[/FONT]
[FONT=arial]Loop 'This loop will run untill there is excel file left[/FONT]
[FONT=arial]End Sub

If you have same headers in all sheets you can merge data from different files with the help of this macro.[/FONT]