this macro will append the usedrange of each worksheet in each selected file into a single worksheet in a new workbook:
Option Explicit
Sub CombineFilesToNewBook()
'
Dim varFilenames As Variant
Dim strActiveBook As String
Dim strSourceDataFile As String
Dim wSht As Worksheet
Dim allwShts As Sheets
Dim intResponse As Integer
Dim counter As Integer
Dim lRows As Long
'
intResponse = MsgBox("This macro will combine all data from all worksheets" & vbCrLf & "from all selected files to a single worksheet in a new workbook. Continue?", vbOKCancel, "Combine Files")
If intResponse = vbOK Then
Workbooks.Add
strActiveBook = ActiveWorkbook.Name
' Create array of filenames; the True is for multi-select
On Error GoTo exitsub
varFilenames = Application.GetOpenFilename(, , , , True)
counter = 1
' ubound determines how many items in the array
On Error GoTo quit
Application.ScreenUpdating = False
While counter <= UBound(varFilenames)
'Opens the selected files
Workbooks.Open varFilenames(counter)
strSourceDataFile = ActiveWorkbook.Name
Set allwShts = Worksheets
For Each wSht In allwShts
' Select Entire UsedRange from Source File
wSht.Activate
ActiveSheet.UsedRange.Select
Selection.Copy
' Find end of usedrange in destination file
Workbooks(strActiveBook).Activate
Range("A1").Select
ActiveSheet.UsedRange.Select
lRows = Selection.Rows.Count
ActiveCell.Offset(lRows, 0).Select
' Copy & Paste All including Formatting
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A1").Select
Next wSht
Workbooks(strSourceDataFile).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
' displays file name in a message box
MsgBox varFilenames(counter) & " Has Been Processed", vbOKOnly + vbInformation, "File Processed"
'increment counter
counter = counter + 1
Wend
quit:
If Err <> 0 Then
MsgBox "An Error Occurred Trying to open the File. Please close any open Excel files and try again", vbOKOnly + vbExclamation, "File Open Error"
On Error GoTo 0
End If
End If
exitsub:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
