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:
 
Hey Everyone,

I know this thread hasn't been all that active in a while, but I have an issue and this is the closest solution I can find.

First, a caveat: I'm not a VBA programmer in the slightest, a fact you will soon find very apparent from my request.

Just like everyone else on this thread, I have been trying to read in data from multiple worksheets into a master sheet.

The original worksheets I am reading from are applications forms for a certain course, and in order to parse the necessary data for the master sheet, I have made a hidden part of the sheet that references the user's inputted data. I tried pointing this macro at the rows where this hidden part is located, but then in my master I get a whole bunch of #REFs that don't really do me any good. Is there a way to set up the macro so it sets up the data referred to, as opposed to the actual reference itself?

I know this isn't a very elegant solution, but thanks in advance for whatever guidance you can give me!

-Hhm
 
Upvote 0

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
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.
I'm sorry to bug y'all but when i try and run your code i get a compile error saying that sub or function not defined and has GetDirectory highlighted. i thought maybe it was a excel 2010 thing but i tried it in 07 and i get the same thing. PLEASE HELP!
 
Upvote 0
I hope some people are still checking these posts :(
I have to merge different workbooks into one.
All the sheets in the given directory are to be moved into one single master file.
The code mentioned above is sufficient to move first sheet of each file but I need to move all the sheets in all the workbooks into master workbook (sheets will become tabs in master file and will not be copied to one single sheet).
 
Upvote 0
Hi Guys,

I have a similar issue except that in my scenario I have many employee workbooks with 'similar' names for example: SDA 1, SDA 2, SDA 3.... They all have the standard three worksheets with names 'Sheet1' ; 'Sheet2'; 'Sheet3' and only 'Sheet1' from all the workbooks have relevant data in it. The header row and column formatting for all the 'Sheet1's in all the workboks is the same.

I have another workbook bythe name of 'Master.xls' which contains the same header row and column as the 'Sheet1' from the above mentioned employee workbooks (SDA 1, SDA 2...).

Can anybody help me with a macro that will combine all rows with data excluding the header row from all the employee workbooks (only Sheet 1) into the Master.xls workbook's Sheet 1 which already has a header row . So, basically all employee data combined and compiled one under the other wih no header rows.

Thank you so much in advance.
 
Upvote 0
Welcome to the board!

This is not precisely what you are looking for maybe, but it should be pretty close - and I already had written it before.

Try putting this code into a new workbook. Put all the workbooks you want to compile into one folder. Then run the code in the new workbook and that workbook will prompt you for a folder and compile everything in the folder. One nice thing about it is that it will check the headers for you and will make one page for each variation of headers. So it is double-checking to make sure that no one inserted columns or re-arranged columns...

Code:
Option Explicit
Dim destSht As Worksheet
Sub Get_Folder_Path()
Dim Folder As String
Folder = Application.GetOpenFilename()
Folder = Left(Folder, Len(Folder) - Len(Split(Folder, "\")(UBound(Split(Folder, "\")))))
On Error Resume Next
If Folder = "" Then Exit Sub
On Error GoTo 0
Call Grab_Raw_Data(Folder)
End Sub
Sub Grab_Raw_Data(Optional FolderPath As String)
Dim FilePath As String
Dim wbook As Workbook
Dim FirstRow As Long, LastRow As Long, FileCount As Integer
Dim strFileArray
Dim lngLoop As Long, x As Long, SkipBook As Boolean, rngCel As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
Set destSht = ThisWorkbook.Sheets(1)
With destSht
    .AutoFilterMode = False
    .Columns.Hidden = False
End With
FileCount = 0
'assign the file names to an array - uses FileList function
strFileArray = FileList(FolderPath, "*.xls*")
 
'Loop through the file names
For x = 0 To UBound(strFileArray)
 
    FilePath = FolderPath & strFileArray(x)
    SkipBook = False
    On Error Resume Next
    Set wbook = Workbooks(Replace(FilePath, FolderPath, ""))
 
    If Not wbook Is Nothing Then
        Workbooks(Replace(FilePath, FolderPath, "")).Close False
    End If
    On Error GoTo 0
 
    On Error GoTo BadWorkbook
    Workbooks.Open Filename:=FilePath, ReadOnly:=True
    Set wbook = Workbooks(Replace(FilePath, FolderPath, ""))
    On Error GoTo 0
        FirstRow = 2
        LastRow = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
 
        'fill in workbook name and row # to serve as unique identifiers
        Cells(1, Columns.Count).End(xlToLeft).Offset(1, 1).Resize(LastRow - 1).Value = wbook.FullName
        Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Value = "Source Book"
        Cells(1, Columns.Count).End(xlToLeft).Offset(1, 1).Resize(LastRow - 1).Formula = "=Row()"
        Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Value = "Row #"
        ActiveSheet.Calculate
 
        For Each rngCel In Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
            rngCel.Value = Trim(rngCel.Value)
        Next
 
        SetDestSht
 
        If LastRow <= 2 Then
            SkipBook = True
            Application.ScreenUpdating = True
            MsgBox "'" & Replace(FilePath, FolderPath, "") & "' contains data.  It is being skipped.", _
            vbInformation, "Skipping " & Replace(FilePath, FolderPath, "")
            Application.ScreenUpdating = False
        End If
 
        If SkipBook = False Then
            Sheets(1).Range(FirstRow & ":" & LastRow).Copy
 
            'paste the data
            With destSht
                .Range("A" & .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row).PasteSpecial Paste:=xlPasteFormats
                .Range("A" & .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row).PasteSpecial Paste:=xlPasteValues
                FileCount = FileCount + 1
            End With
 
            'close the current xls file
            Application.CutCopyMode = False
            wbook.Close False
        End If
 
Next
 
For Each destSht In ThisWorkbook.Sheets
    destSht.Range("1:1").AutoFilter
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
Range("A2").Select
'Tell the user the result
    MsgBox "Data was successfully extracted from " & FileCount & " files.", vbOKOnly, "Extraction Complete"
Exit Sub
BadWorkbook: MsgBox "Cannot open """ & Replace(FilePath, FolderPath, "") & """" & vbCrLf & vbCrLf & _
                "Please delete all collected data, fix this file or eliminate it, then try again.", vbCritical, "Failure"
                With ThisWorkbook.Sheets(1)
                    .Range("2:" & .Rows.Count).ClearContents
                End With
                Application.EnableEvents = True
                Application.ScreenUpdating = True
End Sub
Sub SetDestSht()
Dim testSht As Worksheet, prevBk As Workbook
Set destSht = ThisWorkbook.Sheets(1)
Set prevBk = ActiveWorkbook
    'Fill header values if not filled already
    If Application.WorksheetFunction.CountA(destSht.Range("1:1")) = 0 Then
        Sheets(1).Range("1:1").Copy
        destSht.Range("A1").PasteSpecial Paste:=xlPasteValues
        Exit Sub
    End If
For Each testSht In ThisWorkbook.Sheets
        If Join(Application.Transpose(Application.Transpose(Range("1:1"))), ",") = _
        Join(Application.Transpose(Application.Transpose(testSht.Range("1:1"))), ",") _
        Then
            Set destSht = testSht
            Exit Sub
        End If
Next
 
 
ThisWorkbook.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Set destSht = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
destSht.Cells.Delete
ActiveSheet.UsedRange
prevBk.Activate
Sheets(1).Range("1:1").Copy
destSht.Range("A1").PasteSpecial Paste:=xlPasteValues
End Sub
Function wsExists(wksName As String) As Boolean
    On Error Resume Next
    wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
    On Error GoTo 0
End Function
Function FileList(fldr As String, Optional fltr As String = "*.*") As Variant
    Dim sTemp As String, sHldr As String
    If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
    sTemp = Dir(fldr & fltr)
    If sTemp = "" Then
        FileList = False
        Exit Function
    End If
    Do
        sHldr = Dir
        If sHldr = "" Then Exit Do
        sTemp = sTemp & "|" & sHldr
     Loop
    FileList = Split(sTemp, "|")
End Function

Edit: note, this code presumes headers are in row one and first column is column A.
 
Upvote 0
Thanks Govinda.

I ran the macro and it came up with two different steps.

1. Get_Folder_path: this step takes me to the folder where all my data workbooks are. I can only select one of them, and then click "open". suddenly all spreadsheets on my screen that i'm working on(related or unrelated to the macro) close out and Excel quits.

2. Set destn sheet.: i have not been able to get to the second step because of the rror on the first step.

Please help me out here..

Thank you once again.
 
Upvote 0

Forum statistics

Threads
1,223,246
Messages
6,170,996
Members
452,373
Latest member
TimReeks

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