Wednesday, December 13, 2017

Merge Same Name Worksheet to single worksheet

It so happens, we several excel that has multiple worksheet following same format.
You are in hurry and want to just merge them in to one excel.

Here is what you might do manually.

Select a folder that has all excel that needs to be merged.
Target output excel file will be "\Output\Merged.xlsx"
For each excel
- For each worksheet
- Copy data
- Lookup in merged excel
- - if same worksheet exists then paste at end
- - else create new worksheet and paste
- repeat it.(until you are exhausted)

Below is the VBA macro that targets this exact need.
Create new blank worksheet/excel and run it.
If you new to VBA/Macro and don't know where to place below code and run it only using your excel, click here. (at step 4 paste below code and press F8 and then F5, which will prompt source folder)

This is my first blog entry here. 
Kindly put thanks note if you find it useful.

Sub MergeSameNamedWorkSheets()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim masterwbk As Workbook
    Dim childwbk As Workbook
    Dim wbk1 As Workbook
    Dim filename As String
    Dim Path As String
    Dim NewWkbk As Workbook
    NewWkbk = Workbooks.Add
    Dim mywkb As Workbook

    mywkb = ThisWorkbook
    ThisWorkbook.Sheets(1).Copy Before:=NewWkbk.Sheets(1)
    Dim fldr As FileDialog
    Dim sItem As String

    fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select Source Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
    GetFolder = sItem

    Path = GetFolder & "\" 'CHANGE PATH
    Dim fdObj As Object
    fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists(Path & "Output") = False Then
        fdObj.CreateFolder(Path & "Output")
    End If
    NewWkbk.SaveAs Path & "Output\Merged.xlsx"
    fldr = Nothing

    filename = Dir(Path & "*.xlsx")

    Do While Len(filename) > 0

        Application.ScreenUpdating = True
        ActiveSheet.Cells(ActiveCell.Row + 1, 1).Select()
        ActiveCell.value = Path & filename
        ActiveSheet.Cells(ActiveCell.Row, 2).Select()
        ActiveCell.value = "Started"
        Application.ScreenUpdating = False
        masterwbk = Workbooks.Open(Path & "output\Merged.xlsx")

        Dim masterws() As Object

        Dim str As Object
        For I = 0 To masterwbk.Worksheets.Count - 1
            str = masterwbk.Worksheets(I + 1)
    ReDim Preserve masterws(I + 1) As Variant
            masterws(I) = str.Name
        Next I

        childwbk = Workbooks.Open(Path & filename)

        For I = 1 To childwbk.Worksheets.Count - 1

       Dim ws As Worksheet
       ws = childwbk.ActiveSheet
       Dim childwsname As String
       childwsname = ws.Name
        If LCase(Left(childwsname, 5)) = "sheet" Then GoTo continue

            If Not containsvalue(masterws, childwsname) Then

                ws = masterwbk.Sheets.Add(After:= _
                ws.Name = childwsname
                Dim ubmasterws As Integer
                ubmasterws = UBound(masterws)
                ReDim Preserve masterws(ubmasterws + 1) As Variant
                masterws(ubmasterws) = childwsname
            End If

            Range(Selection, Selection.End(xlToRight)).Select()
            Range(Selection, Selection.End(xlDown)).Select()

            'Set wbk1 = ThisWorkbook
            ActiveSheet.Cells(ActiveCell.Row, 1).Select()
            ActiveSheet.Cells(ActiveCell.Row + 1, ActiveCell.Column).Select()

            If (Len(Trim(Selection.Text)) = 0) Then
                'Application.ScreenUpdating = True
                ActiveSheet.Cells(ActiveCell.Row, 3).Select()
                ActiveCell.value = CInt(ActiveCell.value) + 1
                Application.ScreenUpdating = False
            End If
            Continue For

        Application.CutCopyMode = False

        childwbk.Close False
        masterwbk.Close True

        Application.ScreenUpdating = True
        ActiveSheet.Cells(ActiveCell.Row, 4).Select()
        ActiveCell.value = "Completed"

        Application.ScreenUpdating = False

        filename = Dir
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "All source files are merged and stored at " & Path & "Output\Merged.xlsx"

End Sub

Function containsvalue(values As Object, value As String) As Boolean
    containsvalue = False

    For I = 0 To UBound(values)
        If values(I) = value Then
            containsvalue = True
            Exit For
        End If
        If values(I) = vbEmpty Then
            Exit For
        End If
    Next I

End Function