View Full Version : Automatically combine multiple sheets

11-05-2012, 01:47 PM
I looking for help to adjust the below code for merging multiple workbooks into one. Currently, a userform is activated when the sheet opens. The user is then asked to update the sheets, which technically means that multiple workbooks (each containing two sheets) are merged into one. When the user presses the "update" button, he/she is now asked to locate the folder in which the files are saved. However, to make it easier for the user, I would like the update (merge of data) to happen automatically, when the user presses the "update" button. That is, it should automatically take all .xls files in the folder and combine them into one. Does anyone know this can be done? Any help is much appreciated.

Private Sub CommandButton1_Click()

Dim strFldrPath As String
Dim strCurrentFile As String
Dim wbDest As Workbook
Dim wb As Workbook
Dim WS As Worksheet
Dim arrWS() As String
Dim i As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "C:\Documents and Settings\BA3635\Desktop\New Price lists\Test"
On Error Resume Next: strFldrPath = .SelectedItems(1) & "\"
End With

If strFldrPath = vbNullString Then Exit Sub

strCurrentFile = Dir(strFldrPath & "*.xls*")
Set wbDest = ActiveWorkbook

Application.DisplayAlerts = False
Application.ScreenUpdating = False

'Delete the sheets if they exist
Application.DisplayAlerts = False
On Error Resume Next

For Each WS In ActiveWorkbook.Worksheets
If WS.name <> "Start" And WS.name <> "Instructions" And WS.name <> "Products" And WS.name <> "Horisontal view" And WS.name <> "ProductsOutput" Then
End If

On Error GoTo 0
Application.DisplayAlerts = True

While strCurrentFile <> vbNullString
If strCurrentFile <> wbDest.name Then
Set wb = Workbooks.Open(strFldrPath & strCurrentFile)
ReDim arrWS(1 To wb.Sheets.Count)
i = 0
For Each WS In wb.Sheets
i = i + 1
arrWS(i) = WS.name
Next WS
wb.Sheets(arrWS).Copy After:=wbDest.Sheets(wbDest.Sheets.Count)
wb.Close False
End If
strCurrentFile = Dir

Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Return to sheet1 when update is complete

Unload Me

End Sub

11-06-2012, 11:43 AM
Try the below to work with files

Dim fs, f, fc, fx
Dim rpt

Set fs = CreateObject("Scripting.FileSystemObject") 'create a filesystem object
Set f = fs.GetFolder(strFldrPath) 'create a folder object
Set fc = f.Files 'create an object for files
Application.ScreenUpdating = False
Workbooks.Add 'create a new workbook
rpt = ActiveWorkbook.Name 'get the name of the new workbook
For Each fx In fc 'for each file in the folder, do the below
Workbooks.Open fx 'open file
'merging criteria goes here
Workbooks(fx.Name).Close False 'close file
Workbooks(rpt).SaveAs Filename:= "give the path and filename with extension here"
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Workbooks( merged file name ).Close
Application.ScreenUpdating = True