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

Excel_beginner

New Member
Joined
Jan 15, 2008
Messages
4
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 :confused:
 
Hi I used the code and the error appears on this line

wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)

Runtime Error 1004:
Excel cannot insert the destination worksheet or workbook because it contains fewer rows and columns than the source workbook...
 
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Hi I used the code and the error appears on this line

wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)

Runtime Error 1004:
Excel cannot insert the destination worksheet or workbook because it contains fewer rows and columns than the source workbook...

That is pretty much saying that one of the original workbooks you are trying to combine in this merged file is a newer version. e.g. Excel 2010, xlsx file.

The file this is being combined into is an older version such as Excel 2003 with 65000 rows (and a set no of columns...can't remember of the top of my head how many)

To fix this, change the red highlighted part:

Code:
[COLOR=#333333][I]Sub Merge2MultiSheets()[/I][/COLOR]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 & "\*.[SIZE=4][B][COLOR=#ff0000]xls[/COLOR][/B][/SIZE]", 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
     [COLOR=#333333][I]End Sub[/I][/COLOR]

to

Code:
[COLOR=#333333][I]strFilename = Dir(MyPath & "\*.[/I][/COLOR][SIZE=4][COLOR=#333333][I][B][COLOR=#FF0000]xlsx[/COLOR][/B][/I][/COLOR][/SIZE][COLOR=#333333][I]", vbNormal)[/I][/COLOR]
 
Upvote 0
I have read all the thread and other places at the web
I have put together a good code for mergin several books the first sheet only into one file.
It will allow blank rows, Hope is useful. Just paste it into a new workbook for macross and execute it.
Will require all files to be in the same folder. Will trigger save as at the end.

Code:
Option Explicit
 
 '32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long
 
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long
 
Public Type BrowseInfo
    hOwner As Long
    pIDLRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
 
Function GetDirectory(Optional msg) As String
    On Error Resume Next
    Dim bInfo As BrowseInfo
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
     
     'Root folder = Desktop
    bInfo.pIDLRoot = 0&
     
     'Title in the dialog
    If IsMissing(msg) Then
        bInfo.lpszTitle = "Seleccione el folder con los archivos a fusionar."
    Else
        bInfo.lpszTitle = msg
    End If
     
     'Type of directory to return
    bInfo.ulFlags = &H1
     
     'Display the dialog
    x = SHBrowseForFolder(bInfo)
     
     'Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function


Sub Merge3MultiSheets()


'Description: Combines all files in a folder to a master file.
'Takes all 1st sheets (can have blank rows) and puts into a master workbook with multiple sheets.


Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim fname As Variant
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    MyPath = GetDirectory
    If MyPath = "" Then
        MsgBox "No se seleccionó un directorio" & vbNewLine & "Se detiene la ejecución"
        
        Exit Sub
    Else
           
        Set wbDst = Workbooks.Add(xlWBATWorksheet)
        strFilename = Dir(MyPath & "\*.xls", vbNormal)
    
            If Len(strFilename) = 0 Then
                Exit Sub
            Else
               
                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 If
    End If
    
    fname = Application.GetSaveAsFilename(InitialFileName:="", _
        filefilter:="Excel Files (*.xls), *.xls", _
        Title:="Guardar archivo nuevo como...")


    If fname <> False Then
    
    Set wbDst = ActiveWorkbook
    
    wbDst.SaveAs Filename:=fname, FileFormat:=51
    
    End If
   
    
End Sub
 
Last edited:
Upvote 0
This code also is fuly functional. Also is a merge of a lot of knowledge I found in the web and in this site.
Will merge all worksheets from several workbooks into a file. All workbooks have to be in the same folder.
Will trigger save option to make sure you dont forget to save your new book.

Code:
Option Explicit
 
 '32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long
 
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long
 
Public Type BrowseInfo
    hOwner As Long
    pIDLRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
 
Function GetDirectory(Optional msg) As String
    On Error Resume Next
    Dim bInfo As BrowseInfo
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
     
     'Root folder = Desktop
    bInfo.pIDLRoot = 0&
     
     'Title in the dialog
    If IsMissing(msg) Then
        bInfo.lpszTitle = "Seleccione el folder con los archivos a fusionar."
    Else
        bInfo.lpszTitle = msg
    End If
     
     'Type of directory to return
    bInfo.ulFlags = &H1
     
     'Display the dialog
    x = SHBrowseForFolder(bInfo)
     
     'Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function


Sub fusionar_vhojas()


'Description: Combines all files in a folder to a master file.
'Takes all 1st sheets (can have blank rows) and puts into a master workbook with multiple sheets.


Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim Hoja As Long
Dim fname As Variant


    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    MyPath = GetDirectory
    If MyPath = "" Then
        MsgBox "No se seleccionó un directorio" & vbNewLine & "Se detiene la ejecución"
        
        Exit Sub
    Else
    
        Set wbDst = Workbooks.Add(xlWBATWorksheet)
        strFilename = Dir(MyPath & "\*.xls", vbNormal)
    
        If Len(strFilename) = 0 Then
            Exit Sub
        Else
            Do Until strFilename = ""
        
                Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
            
                For Hoja = 1 To wbSrc.Worksheets.Count
            
                    Set wsSrc = wbSrc.Worksheets(Hoja)
            
                    wsSrc.Copy after:=wbDst.Worksheets(wbDst.Worksheets.Count)
            
                Next Hoja
            
            wbSrc.Close False
        
            strFilename = Dir()
        
            Loop
            wbDst.Worksheets(1).Delete
    
        Application.DisplayAlerts = True
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        End If
    End If
    
    fname = Application.GetSaveAsFilename(InitialFileName:="", _
        filefilter:="Excel Files (*.xls), *.xls", _
        Title:="Guardar archivo nuevo como...")


    If fname <> False Then
    
    Set wbDst = ActiveWorkbook
    
    wbDst.SaveAs Filename:=fname, FileFormat:=51
    
    End If
    
    
End Sub
 
Upvote 0
Are these workbooks all stored in the same folder? Are there other workbooks in this folder what will not be combined into one worksheet? If so, you could try this, but I would highly recommend making a complete copy of the folder you are trying to use this one. They both are very similiar and will ask for the directory to copy from. Just copy this into your master workbook and then choose the directory and off you should go.

Version 1 takes all 1st sheets (can have blank rows) and puts into a master workbook.

Code:
'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
Version 2 takes all 1st sheets (cannot have blank rows) and puts into a master workbook.

Code:
'Description: Combines all files 1st sheet in a folder to a master file
Sub MergeFilesWithoutSpaces()
    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

    ThisWB = ActiveWorkbook.Name
    
    path = GetDirectory("Select a folder containing Excel files you want to merge")
    
    RowofCopySheet = InputBox("Enter Row to start copy on") ' Row to start on in the sheets you are copying from

    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(Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
            Set Dest = shtDest.Range("A" & shtDest.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            CopyRng.Copy
            Dest.PasteSpecial xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False 'Clear Clipboard
            Wkb.Close False
        End If
        
        Filename = Dir()
    Loop

    Range("A1").Select
    Columns.AutoFit
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "Done!"
End Sub
Hope that helps. Sorry I don't know of any books to recommend as I have not read any myself. My learning has been through a visual basic class in college and this board and then trial and error. But the class was by far my most help at getting started.

Can we edit this code to actually select specific files in a given folder?
 
Upvote 0
Hello, i used this coto get different workbooks into 1 excel different sheets and it worked fine, but some file names are in arabic so wnvr i paste the file name it goes smthin like this "???????" anyhelp ? thank u
 
Upvote 0
Hi All,

I have copied the following code from earlier posts and my intent is to add the data from sheet one of multiple CSV files (all in one folder) to Sheet 1 of the main workbook. The problem/challenge I am facing is that the CSV files do open up, and in the debug mode, no errors received...however nothing gets copied to the sheet 1 of the main workbook. Please help!!!

'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 = 4 ' 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")


path = ".\RawData"

Application.EnableEvents = False
Application.ScreenUpdating = False


Set shtDest = ActiveWorkbook.Sheets(1)

Filename = Dir(ThisWorkbook.path & "\RawData\*.csv", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=ThisWorkbook.path & "\RawData" & 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
 
Upvote 0
Ignore above request. I deleted the original excel file, started over again, and without any VBA changes, it worked. Don't know what was wrong there.

Best Regards
 
Upvote 0

Forum statistics

Threads
1,214,918
Messages
6,122,257
Members
449,075
Latest member
staticfluids

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top