Macro merge multiple files into one worksheet

P

psrs0810

Well-known Member
Joined
Apr 14, 2009
Messages
1,109
I have this macro to go to a specific folder and open up all of the files in the folder and merge them into a worksheet.
I want to change it so the user can select the files to be merged.

any suggestions?
thanks

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 = ("F:\Action O-I\Numeric Data Upload\Numeric Response Per Dept\Test")
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ActiveWorkbook.Sheets("Upload File")
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.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy
Sheets("Upload File").Select
Dest.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False 'Clear Clipboard
Wkb.Close False
End If

Filename = Dir()
Loop


Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"
End Sub
 

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.
Sort by date Sort by votes
Thank John_W.
I was able to use the information on the link and started with path = Application.GetOpenFilename and no other information. As soon as I added in the detials in the () it would not work properly.

I did add
' File filters
Filter = "Excel Files (*.xls),*.xls," & _
"Text Files (*.txt),*.txt," & _
"All Files (*.*),*.*"
' Default Filter to *.*
FilterIndex = 3
' Set Dialog Caption
Title = "Select a File to Open"

but now I am getting "Argument not optional"


'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

Sheets("Upload File").Select
Range("A1:D65536").Select
Selection.ClearContents

RowofCopySheet = 1 ' Row to start on in the sheets you are copying from
ThisWB = ActiveWorkbook.Name

path = Application.GetOpenFilename(Filter, FilterIndex, Title, , True)

Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ActiveWorkbook.Sheets("Upload File")
Filename = Dir(path, vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path)
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.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 0)
CopyRng.Copy
Sheets("Upload File").Select
Range("A1").Select
Dest.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False 'Clear Clipboard
Wkb.Close False
End If

Filename = Dir()
Loop


Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"
End Sub
 
Upvote 0
The array of filenames selected by GetOpenFilename replaces your Dir function loop; here is your code modified to use the selected files.
Code: 
Option Explicit

Public Sub MergeFiles()

    Dim path As String
    Dim shtDest As Worksheet
    Dim Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer
    Dim selectedFiles As Variant, filename As Variant
    
    RowofCopySheet = 2 ' Row to start on in the sheets you are copying from
    
    path = ("F:\Action O-I\Numeric Data Upload\Numeric Response Per Dept\Test")
    
    selectedFiles = SelectFiles(path)

    If IsArray(selectedFiles) Then
    
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        
        Set shtDest = ActiveWorkbook.Sheets("Upload File")
    
        'Open and merge each selected file
        
        For Each filename In selectedFiles
            If filename <> ActiveWorkbook.FullName Then
                Set Wkb = Workbooks.Open(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))
                With Wkb.Sheets(1)
                    Set CopyRng = .Range(.Cells(RowofCopySheet, 1), _
                        .Cells(Cells(Rows.Count, 1).End(xlUp).row, .Cells(1, Columns.Count).End(xlToLeft).Column))
                End With
                Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).row + 1)
                CopyRng.Copy
                Dest.PasteSpecial xlPasteValuesAndNumberFormats
                Application.CutCopyMode = False 'Clear Clipboard
                Wkb.Close False
            End If
        Next
    
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    
    Else
    
        MsgBox "No files were selected"
    
    End If
    
    Range("A1").Select
    
    MsgBox "Done!"
    
End Sub

Private Function SelectFiles(startFolderPath As String) As Variant

    Dim Filter As String
    Dim FilterIndex As Integer
    
    'File filters
    Filter = "Excel workbooks (*.xls), *.xls"
    FilterIndex = 1
    
    'Set start drive and path
    ChDrive (startFolderPath)
    ChDir (startFolderPath)
    
    With Application
        'Get array of selected file(s)
        SelectFiles = .GetOpenFilename(Filter, FilterIndex, "Select File(s) to Merge", , MultiSelect:=True)
        
        'Reset start drive and path
        ChDrive (.DefaultFilePath)
        ChDir (.DefaultFilePath)
    End With

End Function
I couldn't get your Set CopyRng line to work with my test workbooks, so I've commented it out and used equivalent code immediately below it.
 
Upvote 0
You can instead select multiple files once and merge then into one at a shot. Use this merge macro. It opens all sheets from all the files you select and merge all data as a consolidated sheet. You header in all sheets columns should be same at least :).
 
Last edited:
Upvote 0
I am trying to use this code for a similar purpose but am getting an error on this line of code:

Code: 
Set shtDest = ActiveWorkbook.Sheets("Book1")

Help?
 
Upvote 0
This sub works great for me, I added a few lines to allow for user input for setting the path.
I currently have an issue with files that are saved with a filter.
I have tried to use: Sheets("Sheet1").AutofilterMode = False
But that does not seem to work.
I have also tried:
Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets ws.AutoFilterMode = False Next ws This also did not work. Can anyone help me with this?
</PRE><!-- END TEMPLATE: bbcode_code --><!-- END TEMPLATE: bbcode_code -->

Here is my variation of the sub:
Option Explicit
Dim myValue As Variant

'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
myValue = InputBox("Enter the folder path of desired files end with a backslash", "Files to Merge")

path = myValue ' Dont't forget to change this
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
 
Upvote 0
psrs0810 said:
an select the files to be merged.
Click to expand...
This Macro is perfectly working, Thank so much

jsauber,​

I need to add, file name in column a so that it can identify to which file the data belongs to , any further assistance will be of a much help tome, Thank you Bhavesh
 
Upvote 0
Bhavesh Gadani said:
This Macro is perfectly working, Thank so much

jsauber,​

I need to add, file name in column a so that it can identify to which file the data belongs to , any further assistance will be of a much help tome, Thank you Bhavesh
Click to expand...
jsauber hasn't posted since 2015 and has not visited this board since 2018.

So you may be better off starting your own thread. You can include a link back to this one, if that is pertinent to your question.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Macro works for one file, does not work for all files in the directory
2
Replies
13
Views
491
Alex Blakenburg
A
J
  • Question
Power Query - Data Refresh Error in Macro
Replies
3
Views
139
bobsan42
bobsan42
J
  • Question
VBA Script - Can't figure out one error...
2
Replies
15
Views
245
Peter_SSs
Peter_SSs
S
  • Question
Open and print a section of word document as pdf
Replies
6
Views
205
StephenBart
S
S
  • Solved
Verify that the workbook name exists and copy the data
Replies
2
Views
322
sofas
S

Forum statistics

Threads
1,215,066
Messages
6,122,948
Members
449,095
Latest member
nmaske

Share this page

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