If you find any post useful then, please do share with others. Thanks!

Popular Posts

Contact

Email me

Need help and that also free? I like to learn this way, in case of any question or for a small task, please feel free to email me with details and example data, if required.

Sunday, January 7, 2018

VBA Code to Combine multiple workbooks in one workbook sheet

We can use the below code to combine multiple workbook in a sheet of single workbook and then save it as well.
 
We first need to have all the workbooks in one folder, they should have same headers. Then open a new workbook and add the below code in a module and run it.
 
We just need to change the path of folder where we have multiple workbooks and then the second path where we will save new file.
 
Sub Merge2MultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Users\khan\Desktop\Weekly Snaps\" 'Path address
Set wbDst = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)

If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True


    Dim i As Integer
    Dim xTCount As Variant
    Dim xWs As Worksheet
    On Error Resume Next

    xTCount = 1
    Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
    xWs.Name = "Combined"
    Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
    For i = 2 To Worksheets.Count
        Worksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount), 0).Copy _
               Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 1)
    Next
   
   
    Dim xWs2 As Worksheet
     Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    For Each xWs2 In Application.ActiveWorkbook.Worksheets
        If xWs2.Name <> "Combined" Then
            xWs2.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ActiveWorkbook.SaveAs Filename:="C:\Users\khan\Desktop\Example.xlsx" 'Path address
End Sub