Macro to select multiple .xls files from same folder and add to new workbook

thelad

Board Regular
Joined
Jan 28, 2011
Messages
245
Hi,

Could someone help me out with the following. I would like a macro that when run will allow me to open a folder and select .xls files in this folder and add the sheets in each file to one workbook. (each file only has one sheet but all have different names).

I'd like each sheet to be copied to new workbook as seperate tabs. (if the original tab name could be kept would be great)

I have done many searching but couldnt find a thread that suits. Closest I found was this:

http://www.mrexcel.com/forum/showthread.php?t=298659&highlight=select+file

Any help would be much appreciated.

This code kinda of works but doesnt if the tab in the files is not named sheet1:

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
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Try this


Code:
Dim oeffnen, n As Integer
Application.ScreenUpdating = False
oeffnen = Application _
.GetOpenFilename(fileFilter:="Excel Files (*.xls), *.xls", MultiSelect:=True)
If IsArray(oeffnen) = False Then GoTo ENDE
For n = 1 To UBound(oeffnen)
    Workbooks.OpenText oeffnen(n)
    ActiveWorkbook.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Workbooks(Mid(oeffnen(n), InStrRev(oeffnen(n), "\") + 1)).Close False
Next n
ENDE:
Application.ScreenUpdating = True
 
Upvote 0
opps

code should be 'Workbooks.Open' - not opentext - sorry I am reading CSV files
 
Upvote 0
Hi,

Thanks for the reply. I'll get back to you on Monday on the success of it.

Thanks
 
Upvote 0
ok - sounds good - I am travelling from Tuesday and onwards until Sunday - so will not reply to any messages in that period - But I think the code will do what u r lokin 4. else google VBA+getopenfilename - u will loads of hits
 
Upvote 0
Hi Rasm,

Thanks for the code. I tried it out and it does work but doesnt work on the excel sheets im trying to move unfortunatly for some reason.

Getting the following error:

Run Time Error '1004':
Copy Method of Worksheet class failed

and when debug its pointing to this line:

ActiveWorkbook.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

Maybe you have another solution? But it does work on other excel files.
 
Upvote 0
Try This - you will have to change to suit your needs - right now it allows you to select multiple files - not sure if that is what you want

Code:
Private Sub CommandButton1_Click()
    FilesToOpen = Application.GetOpenFilename("Excel Files (*.xl*)," & "*.xl*", 1, "Select Excel File", "Open", MultiSelect:=True)
    
    For i = 1 To UBound(FilesToOpen)
        Workbooks.Open FilesToOpen(i)
        With ActiveWorkbook
            For ii = 1 To Sheets.Count
                .Sheets(ii).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            Next ii
        End With
    Next i
End Sub
 
Upvote 0
you may want to close opened file after it is copied - up yo you


Code:
Private Sub CommandButton1_Click()
    FilesToOpen = Application.GetOpenFilename("Excel Files (*.xl*)," & "*.xl*", 1, "Select Excel File", "Open", MultiSelect:=True)
    
    For i = 1 To UBound(FilesToOpen)
        Workbooks.Open FilesToOpen(i)
        With ActiveWorkbook
            For ii = 1 To Sheets.Count
                .Sheets(ii).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            Next ii
            .Close 'closes file after it is copied
        End With
       
    Next i
End Sub
 
Upvote 0
Hi Rasm,

I have the code as follows but still didnt work. It does work on some excel files however not on the ones im trying to add. On some the cells there is formula's:

IF(PARM_Z_MultiPeriodReport=1,W9,X9)

what I used to have to do was copy the sheet, then paste special values back onto the sheet and copy again so I could copy and paste to another sheet easily. So maybe thats why it is not working?

On the sheets im trying to add

Sub Merge2MultiSheets()
Dim oeffnen, n As Integer
Application.ScreenUpdating = False
oeffnen = Application _
.GetOpenFilename(fileFilter:="Excel Files (*.xls), *.xls", MultiSelect:=True)
If IsArray(oeffnen) = False Then GoTo ENDE
For n = 1 To UBound(oeffnen)
Workbooks.OpenText oeffnen(n)
ActiveWorkbook.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Workbooks(Mid(oeffnen(n), InStrRev(oeffnen(n), "\") + 1)).Close False
Next n
ENDE:
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
FilesToOpen = Application.GetOpenFilename("Excel Files (*.xl*)," & "*.xl*", 1, "Select Excel File", "Open", MultiSelect:=True)

For i = 1 To UBound(FilesToOpen)
Workbooks.Open FilesToOpen(i)
With ActiveWorkbook
For ii = 1 To Sheets.Count
.Sheets(ii).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next ii
.Close 'closes file after it is copied
End With

Next i
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,487
Messages
6,113,937
Members
448,534
Latest member
benefuexx

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