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 Microsoft Visual Basic Mode

Double Click ThisWorkbook on the left column

Copy paste the code below in the right text box column

Option Explicit

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
For i = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step -1
Next i
End If
Application.DisplayAlerts = True

Set mainLastEnd(i) = GetTrueEnd(ThisWorkbook.Sheets(i))
Next i

‘ Load the data
For Each externWorkbookFilepath In GetWorkbooks()
Set externWorkbook = Application.Workbooks.Open(externWorkbookFilepath, , True)


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))
‘ 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

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”, _
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.

Tinggalkan Balasan

Isikan data di bawah atau klik salah satu ikon untuk log in:


You are commenting using your account. Logout /  Ubah )

Foto Facebook

You are commenting using your Facebook account. Logout /  Ubah )

Connecting to %s

This site uses Akismet to reduce spam. Learn how your comment data is processed.

%d blogger menyukai ini: