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
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
No comments:
Post a Comment