Merge multiple sheets from multiple workbooks into one new sheet

Hi Jens

I'm just starting to get back to using VBA and a little bit rusty so appreciate any help you may be able to give around this...

I have multiple workbooks with multiple worksheets (the number of worksheets is not consistent across the workbooks and will vary over time) and I would like to merge them all into one worksheet in a new workbook. All the worksheets on every single workbook contain the exact same column headings which I would also like to include in the new worksheet.

I have used some of you code from previous forum questions mixed with my own but can't seem to get it to work - I think the issue is around line 39 - 42 where it currently picks just sheet 1 rather than all the sheets in the workbook so my loop just duplicates sheet 1 several times...

I also can't work out how to include the column headings (they are the same on every worksheet)...

Any help appreciated, even if you use completely different code!





Sub MergeAllWorkbooks()
Dim FolderPath As String 'store the folderpath in the computer's memory
Dim FileName As String 'store the file name inthe computer's memory
Dim WorkBk As Workbook 'store the name of each workbook in the computer's memory
Dim blankrow As Integer 'store the row number of the first blank row in destination sheet
Dim varAllData As Variant 'array. Will store all records from the source workbooks
Dim Current As Worksheet ' Declare Current as a worksheet object variable.


'speed up macro
Application.ScreenUpdating = False
Application.DisplayAlerts = False


'open the select directory dialog box
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then '-1 = yes or true
FolderPath = .SelectedItems(1) & "\"
Else
MsgBox "FilePath not selected!", , "Path selecter"
Exit Sub
End If
End With

'Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")

'Loop until Dir returns an empty string
Do While FileName <> ""
'Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)


For Each Current In Worksheets ' Loop through all of the worksheets in the active workbook

'This is where I begin to get muddled...

varAllData = WorkBk.Sheets(1).Range("a1").CurrentRegion.Offset(1, 0) 'selects sheet 1 from all workbooks and all data excluding the header
ThisWorkbook.Sheets("Sheet3").Activate 'name the location where you want the data to go
blankrow = Range("a1").CurrentRegion.Rows.Count + 1 'starting cell for data to be addedd to
Range("A" & blankrow).Resize(UBound(varAllData, 1), UBound(varAllData, 2)) = varAllData 'what you want to insert into that space

Next

'Need a clause to close the loop

'Close the source workbook without saving changes
WorkBk.Close savechanges:=False

'Use Dir to get the next file name
FileName = Dir()

Loop
Columns.AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub