Using VBA scripts to Combine multiple workbooks of different number of worksheet(s) to a single workbook of multiple worksheets

[Ammarbokhari]

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:\MyPath" ' change to suit
Set wbDst = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(MyPath & "\*.xls", 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

End Sub


I found this code in a similar (2 year old) post by someone in this forum.
Now I think nobody will post a reply to my question in that thread, so I am starting a new one.
I am looking for a code which will move all the sheets in the directory to one single workbook and the source workbook should remain intact.
(Instead of this code I need a code which will copy all the workbooks not just one, and the code should not delete the source file or any of its contents)
I am below Zero when it comes to VBA, so please help me out.

 

[pboltonchina]

Try this on a copy of your data

Option Explicit

'Combine Workbooks
'By Tommy Miles
'This sample goes through all the Excel files in a specified directory and combines theminto
'a single workbook.  It renames the sheets based on the name of the original workbook:
Sub CombineWorkbooks()
Dim CurFile As String, DirLoc As String
Dim DestWb As Workbook
Dim ws As Object 'allows for different sheet types

DirLoc = ThisWorkbook.path & "\tst\" 'location of files
CurFile = Dir(DirLoc & "*.xls")

Application.ScreenUpdating = False
Application.EnableEvents = False

Set DestWb = Workbooks.Add(xlWorksheet)

Do While CurFile <> vbNullString
    Dim OrigWb As Workbook
    Set OrigWb = Workbooks.Open(filename:=DirLoc & CurFile, ReadOnly:=True)
    
    ' Limit to valid sheet names and remove .xls*
    CurFile = Left(Left(CurFile, Len(CurFile) - 5), 29)
    
    For Each ws In OrigWb.Sheets
        ws.Copy After:=DestWb.Sheets(DestWb.Sheets.Count)
        
        If OrigWb.Sheets.Count > 1 Then
            DestWb.Sheets(DestWb.Sheets.Count).Name = CurFile & ws.Index
        Else
            DestWb.Sheets(DestWb.Sheets.Count).Name = CurFile
        End If
    Next
    
    OrigWb.Close SaveChanges:=False
    CurFile = Dir
Loop

Application.DisplayAlerts = False
    DestWb.Sheets(1).Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = True
Application.EnableEvents = True

Set DestWb = Nothing

End Sub

 

[davidtaylor598]

Hi pboltonchina,

Thanks for the code. However, I am having some trouble getting it to work. It has been a long time since I have worked with VBA so I am very rusty at the moment and can't work out what I need to change. At the moment my macro is falling down at this part:

CurFile = Dir(DirLoc & "*.xls")

Say the book with my macro in is called, Book1.xls, and the files that I want to use to combine into one workbook are in the same folder, say C/My docs/..., how do I interpret this? I guess I have to change something on the line above it as well?

Thanks

 

[pboltonchina]

Change

DirLoc = ThisWorkbook.path & "\tst\" 'location of files
CurFile = Dir(DirLoc & "*.xls")

to

DirLoc = "C/My docs/" 'location of files
CurFile = Dir(DirLoc & "Book1.xls")

 

[davidtaylor598]

Thanks,

I'm not getting an automation error. Using your code before I was only able to copy in worksheets called 'Sheet1' and I need to copy in worksheets whatever the name. I set up a For Loop to deal with this but it is coming up with an Automation error, see below.

Sub MergeWorkbooks()
  Dim wbkCur As Workbook
  Dim wbkAdd As Workbook
  Dim strPath As String
  Dim strFile As String
  Set wbkCur = ActiveWorkbook
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then
      strPath = .SelectedItems(1)
    Else
      MsgBox "You didn't select a folder!", vbExclamation
      Exit Sub
    End If
  End With
  Application.ScreenUpdating = False
  If Right(strPath, 1) <> "\" Then
    strPath = strPath & "\"
  End If
  strFile = Dir(strPath & "*.xls*")
  Do While strFile <> ""
    Set wbkAdd = Workbooks.Open(strPath & strFile)
    For i = 1 To wbkAdd.Worksheets.Count

        wbkAdd.Worksheets(i).Copy After:=wbkCur.Worksheets(wbkCur.Worksheets.Count)
        wbkAdd.Close SaveChanges:=False
        strFile = Dir
    Next
  Loop
  Application.ScreenUpdating = True
End Sub

For i = 1 To wbkAdd.Worksheets.Count is coming up as an Automation error. Do you know why this is?

 

[pbcnick]

Thanks,

I'm not getting an automation error. Using your code before I was only able to copy in worksheets called 'Sheet1' and I need to copy in worksheets whatever the name. I set up a For Loop to deal with this but it is coming up with an Automation error, see below.

Sub MergeWorkbooks()
  Dim wbkCur As Workbook
  Dim wbkAdd As Workbook
  Dim strPath As String
  Dim strFile As String
  Set wbkCur = ActiveWorkbook
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then
      strPath = .SelectedItems(1)
    Else
      MsgBox "You didn't select a folder!", vbExclamation
      Exit Sub
    End If
  End With
  Application.ScreenUpdating = False
  If Right(strPath, 1) <> "\" Then
    strPath = strPath & "\"
  End If
  strFile = Dir(strPath & "*.xls*")
  Do While strFile <> ""
    Set wbkAdd = Workbooks.Open(strPath & strFile)
    For i = 1 To wbkAdd.Worksheets.Count

        wbkAdd.Worksheets(i).Copy After:=wbkCur.Worksheets(wbkCur.Worksheets.Count)
        wbkAdd.Close SaveChanges:=False
        strFile = Dir
    Next
  Loop
  Application.ScreenUpdating = True
End Sub

For i = 1 To wbkAdd.Worksheets.Count is coming up as an Automation error. Do you know why this is?

did you ever get this to work?
I am in need of something similar.

 

[DebDell]

did you ever get this to work?
I am in need of something similar.

I worked on your code and came up with this. I just moved the Next statement up two lines. I'm new to this forum so I hope I post this correctly. The next should before you close the workbook.

Sub MergeWorkbooks()
  Dim wbkCur As Workbook
  Dim wbkAdd As Workbook
  Dim strPath As String
  Dim strFile As String
  Set wbkCur = ActiveWorkbook
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then
      strPath = .SelectedItems(1)
    Else
      MsgBox "You didn't select a folder!", vbExclamation
      Exit Sub
    End If
  End With
  Application.ScreenUpdating = False
  If Right(strPath, 1) <> "\" Then
    strPath = strPath & "\"
  End If
  strFile = Dir(strPath & "*.xls*")
  Do While strFile <> ""
    Set wbkAdd = Workbooks.Open(strPath & strFile)
    For i = 1 To wbkAdd.Worksheets.Count
        wbkAdd.Worksheets(i).Copy After:=wbkCur.Worksheets(wbkCur.Worksheets.Count)
    Next
    wbkAdd.Close SaveChanges:=False
    strFile = Dir
  Loop
  Application.ScreenUpdating = True
End Sub

 

[Igor4]

Here is a Code to merge multiple excel workbooks and insert it into a new spreadsheet.
Open NEW Excel file that you want to combine other workbooks into.
Click (Alt+F11) Developer > Visual Basic, a new Microsoft Visual Basic for applications window will be displayed, click Insert > Module, and input the following code into the Module:

Sub GetSheets()
Path = "C:\Financial Statements Merge\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub

Tip: In the above code, you can change the Path (second line of the code) to the one that you are using