How to Merge Many XLS Files into One File

How to Merge Many XLS Files into One File?
It will combine many xls files into a single spreadsheet file including the worksheet!
Just create new XLS File Then press Alt+F11 to go to Microsoft Visual Basic Mode
Double Click ThisWorkbook on the left column

Copy paste the code below in the right text box column
  Option Explicit Const NUMBER_OF_SHEETS = 4 Public Sub GiantMerge() Dim externWorkbookFilepath As Variant Dim externWorkbook As Workbook Dim i As Long Dim mainLastEnd(1 To NUMBER_OF_SHEETS) As Range Dim mainCurEnd As Range Application.ScreenUpdating = False ' Initialise ' Correct number of sheets Application.DisplayAlerts = False If ThisWorkbook.Sheets.Count < NUMBER_OF_SHEETS Then ThisWorkbook.Sheets.Add Count:=NUMBER_OF_SHEETS - ThisWorkbook.Sheets.Count ElseIf ThisWorkbook.Sheets.Count > NUMBER_OF_SHEETS Then For i = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step -1 ThisWorkbook.Sheets(i).Delete Next i End If Application.DisplayAlerts = True For i = 1 To NUMBER_OF_SHEETS Set mainLastEnd(i) = GetTrueEnd(ThisWorkbook.Sheets(i)) Next i ' Load the data For Each externWorkbookFilepath In GetWorkbooks() Set externWorkbook = Application.Workbooks.Open(externWorkbookFilepath, , True) For i = 1 To NUMBER_OF_SHEETS If mainLastEnd(i).Row > 1 Then ' There is data in the sheet ' Copy new data (skip headings) externWorkbook.Sheets(i).Range("A2:" & GetTrueEnd(externWorkbook.Sheets(i)).Address).Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, 1) ' Find the end column and row Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i)) Else ' No nata in sheet yet (prob very first run) ' Get correct sheet name from first file we check ThisWorkbook.Sheets(i).Name = externWorkbook.Sheets(i).Name ' Copy new data (with headings) externWorkbook.Sheets(i).Range("A1:" & GetTrueEnd(externWorkbook.Sheets(i)).Address).Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row, 1) ' Find the end column and row Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i)).Offset(, 1) ' Add file name heading ThisWorkbook.Sheets(i).Cells(1, mainCurEnd.Column).Value = "File Name" End If ' Add file name into extra column ThisWorkbook.Sheets(i).Range(ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, mainCurEnd.Column), mainCurEnd).Value = externWorkbook.Name Set mainLastEnd(i) = mainCurEnd Next i externWorkbook.Close Next externWorkbookFilepath Application.ScreenUpdating = True End Sub ' Returns a collection of file paths, or an empty collection if the user selects cancel Private Function GetWorkbooks() As Collection Dim fileNames As Variant Dim xlFile As Variant Set GetWorkbooks = New Collection fileNames = Application.GetOpenFilename(Title:="Please choose the files to merge", _ FileFilter:="Excel Files, *.xls;*.xlsx", _ MultiSelect:=True) If TypeName(fileNames) = "Variant()" Then For Each xlFile In fileNames GetWorkbooks.Add xlFile Next xlFile End If End Function ' Finds the true end of the table (excluding unused columns/rows and rows filled with 0's) Private Function GetTrueEnd(ws As Worksheet) As Range Dim lastRow As Long Dim lastCol As Long Dim r As Long Dim c As Long On Error Resume Next lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row On Error GoTo 0 If lastCol <> 0 And lastRow <> 0 Then ' look back through the last rows of the table, looking for a non-zero value For r = lastRow To 1 Step -1 For c = 1 To lastCol If ws.Cells(r, c).Text <> "" Then If ws.Cells(r, c).Text <> 0 Then Set GetTrueEnd = ws.Cells(r, lastCol) Exit Function End If End If Next c Next r End If Set GetTrueEnd = ws.Cells(1, 1) End Function

Press F5 There you go.
If you have 4 sheets, just change the 2nd line:
Const NUMBER_OF_SHEETS = 3

Into:
Const NUMBER_OF_SHEETS = 4

http://superuser.com/questions/304899/how-can-i-merge-hundreds-of-excel-spreadsheet-files