VBA to merge sheet from multiple excel files into one master file

[CutterSoilMixing]

Hello everyone,

I have a VBA code that merges worksheets (named "Data" in this case) from all excel files in a folder into one workbook and creates a new tab for each. I'm struggling with two issues at the moment and would greatly appreciate any input:

1. currently, I have to manually enter the folder path containing the files I want to merge and the files are always in a different folder. I'd like to set this up so that a window pops up that allows me to select the folder.

2. the code copies the entire worksheet from the source, creates a new worksheet in the master and then pastes the data there. If the master already contains Sheet1 and Sheet2 the code overwrites both sheets with data from the source files. Is there a way to tell the code to start inserting new worksheets after sheet1 and sheet2? I've played around with iCnt in the code but no luck...

Thanks you very much in advance and all the best!

Option Explicit

Private Sub CommandButton1_Click()
    mergeData
End Sub

Sub mergeData()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    ' Our FileSystem Objects.
    Dim objFs As Object
    Dim objFolder As Object
    Dim file As Object
    
    Set objFs = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFs.GetFolder("INSERT FOLDER PATH CONTAINING FILES TO MERGE HERE")       ' The path of the source files.
    
    Dim iCnt As Integer     ' Just a counter.
    iCnt = 1
    
    ' Loop through all the files in the folder.
    For Each file In objFolder.Files
    
        Dim objSrc As Workbook     ' The source.
        Set objSrc = Workbooks.Open(file.Path, True, True)
        
        Dim iTotalRows As Integer       ' The total rows used in the source file.
        iTotalRows = objSrc.Worksheets("Data").UsedRange.Rows.Count
        
        Dim iTotalCols As Integer       ' Now, get the total columns in the source.
        iTotalCols = objSrc.Worksheets("Data").UsedRange.Columns.Count
        
        Dim iRows, iCols As Integer
        
        ' Read data from source and copy in the master file.
        For iRows = 1 To iTotalRows
            For iCols = 1 To iTotalCols
                Application.Workbooks(1).ActiveSheet.Cells(iRows, iCols) = _
                        objSrc.Worksheets("Data").Cells(iRows, iCols)
                            ' Note: It will read data in "Sheet1" of the source file.
            Next iCols
        Next iRows
        
        iRows = 0
        
        ' Get the name of the file (I'll name the active sheet with the filename).
        Dim sSheetName As String
        sSheetName = Replace(objSrc.Name, ".xlsx", "")          ' I am assuming the files are .xlsx files.
        
        ' Close the source file (the file from which its copying the data).
        objSrc.Close False
        Set objSrc = Nothing
        
        With ActiveWorkbook
            .ActiveSheet.Name = sSheetName           ' Rename the sheet.
            iCnt = iCnt + 1
            
            If iCnt > .Worksheets.Count Then
                ' Create or add a new sheet after the last sheet.
                .Sheets.Add After:=.Worksheets(.Worksheets.Count)
            End If
            
            .Worksheets(iCnt).Activate      ' Go to the next sheet.
        End With

    Next
    
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[NdNoviceHlp]

Hi CutterSoilMixing. You can trial this. HTH. Dave

Sub test()
Dim FSO As Object, FolDir As Object, FileNm As Object
Dim TargetFolder As FileDialog, Sht As Worksheet, Cnter As Integer
Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
On Error GoTo Erfix
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".xls" & "*" Then
Workbooks.Open Filename:=FileNm
For Each Sht In Workbooks(FileNm.Name).Worksheets
If LCase(Sht.Name) = LCase("Data") Then
Cnter = Cnter + 1
Workbooks(FileNm.Name).Sheets("Data").copy _
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Sht.Name = "Data" & Cnter
Workbooks(FileNm.Name).Close savechanges:=False
Exit For
End If
Next Sht
End If
Next FileNm
Erfix:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
End Sub

 

[CutterSoilMixing]

Hi CutterSoilMixing. You can trial this. HTH. Dave

Sub test()
Dim FSO As Object, FolDir As Object, FileNm As Object
Dim TargetFolder As FileDialog, Sht As Worksheet, Cnter As Integer
Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
On Error GoTo Erfix
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".xls" & "*" Then
Workbooks.Open Filename:=FileNm
For Each Sht In Workbooks(FileNm.Name).Worksheets
If LCase(Sht.Name) = LCase("Data") Then
Cnter = Cnter + 1
Workbooks(FileNm.Name).Sheets("Data").copy _
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Sht.Name = "Data" & Cnter
Workbooks(FileNm.Name).Close savechanges:=False
Exit For
End If
Next Sht
End If
Next FileNm
Erfix:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
End Sub

Hi NdNoviceHlp, thank you very much for this, the VBA does exactly what I needed!

Is there maybe a way to name the new sheets with the name of the source file? The VBA currently creates new sheets and calls them Data, Data (1), Data (2) etc. but if it could name the new tabs with the filename from which the data is copied that would be perfect.

Thanks again!

 

[NdNoviceHlp]

Maybe...

Sht.Name = Left(FileNm.Name, Len(FileNm.Name)-5)

Dave

 

[CutterSoilMixing]

Maybe...

Sht.Name = Left(FileNm.Name, Len(FileNm.Name)-5)

Dave

Thanks Dave for your quick response! This is interesting: I modified the one line in the VBA and it's still naming the sheets Data, Data (1), Data (2) etc in the master sheet BUT it's also changing the name of the source sheet to the file name. So the VBA is doing what we want it to just not in the right location.

 

[Fluff]

Try it like

ActiveSheet.Name = Left(FileNm.Name, Len(FileNm.Name)-5)

 

[NdNoviceHlp]

Hmmm. I have no idea how it could possibly be naming the sheets Data1 etc. unless we accidently re-named the other wb sheets which is impossible because we were not saving the changes to the wb. Anyways, Fluff is right or..
replace the line of code with...

ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name=Left(FileNm.Name, Len(FileNm.Name)-5)

Dave

 

[Fluff]

Whilst it may not be a problem for the OP, I would advise against using that as if the last sheet is hidden, then the new sheet will be the penultimate sheet & you will rename the wrong one.

 

[CutterSoilMixing]

Alright, it's working now :D both options seem to be running smooth.

Thank you both very much for your help! Here's the final code for your reference:

Sub test()
Dim FSO As Object, FolDir As Object, FileNm As Object
Dim TargetFolder As FileDialog, Sht As Worksheet, Cnter As Integer
Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
On Error GoTo Erfix
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".xls" & "*" Then
Workbooks.Open Filename:=FileNm
For Each Sht In Workbooks(FileNm.Name).Worksheets
If LCase(Sht.Name) = LCase("Data") Then
Cnter = Cnter + 1
Workbooks(FileNm.Name).Sheets("Data").Copy _
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = Left(FileNm.Name, Len(FileNm.Name) - 5)
Workbooks(FileNm.Name).Close savechanges:=False
Exit For
End If
Next Sht
End If
Next FileNm
Erfix:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
End Sub

 

[NdNoviceHlp]

You are welcome and thanks for posting your outcome. You can remove the "cnter" stuff as it is no longer needed. Thanks Fluff.... I was not aware of that possibility. Have a nice day. Dave