Talk and Chats All About Life: 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

Talk and Chats All About Life

Wednesday, February 18, 2015

How to Merge Many XLS Files into One File

No comments:

Post a Comment