Using VBA scripts to Combine multiple workbooks of single worksheet to a single workbook of multiple worksheets

[Excel_beginner]

I am a beginner to Excel and VBA, can somebody show me a few lines of scripts and instructions how to use VBA scripts to combine multiple Excel xls Files (which contain single worksheet) into a single Excel file of multiple worksheets?

Can somebody also suggest a good book with examples I can start to learn to solve these kinds of problems?

Thanks very much

Excel_beginner

 

[joaosantos]

This will combine workbooks with a single sheet into a new workbook with multiple sheets.

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

using this code

 

[joaosantos]

Anyone?

 

[ChrisG85]

I'm using the following macro:

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

And it works great. However, I need it to go through multiple subfolders and combine the worksheets into new workbooks one at a time. Is there a way to add another loop into this code to achieve this?

 

[Norie]

If you wanted to go through all the subfolders of folder, and then the subfolders of those subfolders and so on you would need to use recursion.

Where would the data/sheets from each workbook in each folder end up?

 

[ChrisG85]

It would only be one layer of subfolders...

Could something be written into it to place the created workbooks in a specified folder?

 

[Norie]

Would there be a separate workbook for each folder?

By the way, the code to do this would be quite a bit different than the original code - it would probably use the FileSystemObject to get the subfolders.

PS I think you need to delete some old messages from your Inbox/Sent Items folders if you want to receive any new PMs.

 

[ChrisG85]

Yes, I'd need a separate workbook for each folder. Would this be something difficult to achieve?

I can only have one message in my inbox AND sent folders TOTAL... so I have to delete each time I send a message. Sorry!

 

[Pinaki Chatterjee]

Hello Norie

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\pchatte1\Documnets\abcd" ' 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 am getting an error on the same. Run Time Error 52 for this code line strFilename = Dir(MyPath & "\*.xls", vbNormal).

Can you see. I have multiple workbook with single sheet in a folder. I want to copy each sheet from each work book to single file in an open excel. Please check and guide

 

[Pinaki Chatterjee]

This worked great...EXCEPT I do not have anything in Column A on some of my spreadsheets on the last row, so it is excluding that entire row. Is there a way to change part of the code to loop through a different column until it is blank or a way around this? ex. Column C has data in all rows that are eligible to be copied.

Anything would help thanks! I'm using the code below:

'Description: Combines all files in a folder to a master file.
Sub MergeFiles()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer

RowofCopySheet = 2 ' Row to start on in the sheets you are copying from

ThisWB = ActiveWorkbook.Name

path = GetDirectory("Select a folder containing Excel files you want to merge")

Application.EnableEvents = False
Application.ScreenUpdating = False

Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest
Wkb.Close False
End If

Filename = Dir()
Loop

Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"
End Sub


Thanks, aelliottmo

Hi Aelliottmo,
I have gone through the code, it is giving me error on path = GetDirectory("Select a folder containing Excel files you want to merge") part. Can you re share the code