Consulting

Results 1 to 2 of 2

Thread: Automatically combine multiple sheets

  1. #1
    VBAX Newbie
    Joined
    Nov 2012
    Posts
    1
    Location

    Automatically combine multiple sheets

    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.

    [vba]
    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"
    .Show
    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
    WS.Delete
    End If
    Next

    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
    Wend

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    'Return to sheet1 when update is complete
    Sheets("Start").Select

    Unload Me

    End Sub [/vba]

  2. #2
    VBAX Regular GreenDR's Avatar
    Joined
    Oct 2012
    Location
    India
    Posts
    25
    Location
    Try the below to work with files

    [VBA]
    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
    Next
    Workbooks(rpt).SaveAs Filename:= "give the path and filename with extension here"
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Workbooks( merged file name ).Close
    Application.ScreenUpdating = True
    [/VBA]
    GreenDR

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •