Consulting

Results 1 to 8 of 8

Thread: Merge Workbooks into one - Help in Folder Picker

  1. #1
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location

    Merge Workbooks into one - Help in Folder Picker

    Hi,

    I was trying to change the below pre defined path (Option-1) in the code to a folder pick (Option -2). But, it is not working and i'm unable to figure it out. Somebody please help me, what wrong I'm doing?

    Option -1
    xStrPath = "C:\Users\anish.ms\Desktop\Sample\"
    xStrFName = Dir(xStrPath & "*.xlsx")
    Option - 2
    xStrPath = Application.FileDialog(msoFileDialogFolderPicker).Show
    xStrFName = xStrPath & "*.xlsx"
    'Merge Workbooks into one (each worksheet will be named with prefix of its original file name)
    
    
    Sub MergeWorkbooks()
    
    
    Dim xStrPath As String
    Dim xStrFName As String
    Dim xWS As Worksheet
    Dim xMWS As Worksheet
    Dim xTWB As Workbook
    Dim xStrAWBName As String
    On Error Resume Next
    xStrPath = "C:\Users\anish.ms\Desktop\Sample\"
    xStrFName = Dir(xStrPath & "*.xlsx")
    
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set xTWB = ActiveWorkbook
    Do While Len(xStrFName) > 0
        Workbooks.Open Filename:=xStrPath & xStrFName, ReadOnly:=True
        xStrAWBName = ActiveWorkbook.Name
        For Each xWS In ActiveWorkbook.Sheets
        xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
        Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
        xMWS.Name = xStrAWBName & "(" & xMWS.Name & ")"
        Next xWS
        Workbooks(xStrAWBName).Close
        xStrFName = Dir()
    Loop
    
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub
    Thanks
    Take care, stay safe

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Define "not working"


    Didn't test WS copy code


    Option Explicit
    
    
    'Merge Workbooks into one (each worksheet will be named with prefix of its original file name)
    
    
    
    
    Sub MergeWorkbooks()
        Dim xStrPath As String
        Dim xStrFName As String
        Dim xWS As Worksheet
        Dim xMWS As Worksheet
        Dim xTWB As Workbook
        Dim xStrAWBName As String
        
        'REALLY don't use On Error Resume Next when you're trying to find an error in your macro
        'Probably NEVER make first line in macro anyway
       'On Error Resume Next
        'xStrPath = "C:\Users\anish.ms\Desktop\Sample\"
        'xStrFName = Dir(xStrPath & "*.xlsx")
        
        'right way to call
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            If .SelectedItems.Count = 1 Then
                xStrPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
        
        
        'added backslash
        xStrFName = Dir(xStrPath & "\*.xlsx")
        
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        
        
        Set xTWB = ActiveWorkbook
        Do While Len(xStrFName) > 0
        
            'added backslash
            Workbooks.Open Filename:=xStrPath & "\" & xStrFName, ReadOnly:=True
            xStrAWBName = ActiveWorkbook.Name
            For Each xWS In ActiveWorkbook.Sheets
            xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
            Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
            xMWS.Name = xStrAWBName & "(" & xMWS.Name & ")"
            Next xWS
            Workbooks(xStrAWBName).Close
            xStrFName = Dir()
        Loop
        
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
    
    
    End Sub
    Last edited by Paul_Hossler; 03-31-2021 at 06:38 PM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    Thanks Paul!
    Noted your comments and the codes are working fine.
    But I have a problem here; if the target sheet name (file name + sheet name) length is more than the allowed length.
    Can you help me to modify the code to copy the target workbook sheets in one sheet one after another below with xMWS.Name in column A and the data from column B?
    Last edited by anish.ms; 03-31-2021 at 10:22 PM.

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Not sure I understand the question, but WS names are limited to 31 char and there's no way around that I know

    The only suggestion I could come up with (and it's not great) is to

    1. Copy each WS from each WB and give it a 'generic' safe name ('Copy_001')

    2. Have a table of contents WS in the WB that has

    Col A = Copy_001
    Col B = "Sales for 2020.xlsx"
    Col C = "Janurary"

    Col A could be a hyperlink to go to that sheet

    You could add a button to Copy_001 after you copy it into the master WB to return to the TOC sheet
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  5. #5
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    Thanks Paul! that's a great option.

    I have done below for the time being

    xMWS.Name = Left(xStrAWBName & "(" & xMWS.Name & ")", 31)
    The contents are same in all the WB and it is copied into different WS due to the limitation of 65K rows (.xls files)
    My thought was to copy each WS from each WB and paste in one WS in master WB.

    In Master WS
    Col A =
    WB Name
    Col B = Each WS name from each WB
    Col C onwards = Col A.Usedrange in each WS from each WB
    after copying all the WS in WB, I can delete the headings
    Last edited by anish.ms; 04-01-2021 at 11:24 AM.

  6. #6
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    I have modified the code as below to copy each WS from each WB and paste in one WS

    Option Explicit
    
    
    Sub Test1()
        Dim xStrPath As String
        Dim xStrFName As String
        Dim xWS    As Worksheet
        Dim xCopyWS   As Worksheet
        Dim xMasterWB   As Workbook
        Dim xMasterWS   As Worksheet
        Dim Last_Row As Long
        Dim xStrAWBName As String
        Dim Check  As Boolean
        Dim r      As Range
    
    
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            If .SelectedItems.Count = 1 Then
                xStrPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
        
        xStrFName = Dir(xStrPath & "\*.xl*")
        
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        Set xMasterWB = ActiveWorkbook
        
        For Each xWS In xMasterWB.Worksheets
            If xWS.Name Like "Consolidated" Then Check = True: Exit For
        Next
        If Check = True Then
            MsgBox "Worksheet Consolidated Already Exists"
            Exit Sub
        Else
            xMasterWB.Sheets.Add.Name = "Consolidated"
            Set xMasterWS = xMasterWB.Sheets("Consolidated")
            Last_Row = 1
            xMasterWS.Range("A1").Value = "WorkBook Name"
            xMasterWS.Range("B1").Value = "WorkSheet Name"
        End If
        
        Do While Len(xStrFName) > 0
            
            Workbooks.Open Filename:=xStrPath & "\" & xStrFName, ReadOnly:=True
            xStrAWBName = ActiveWorkbook.Name
            For Each xWS In ActiveWorkbook.Sheets
                xMasterWS.Cells(Last_Row + 1, 1) = xStrAWBName
                xMasterWS.Cells(Last_Row + 1, 2) = xWS.Name
                xWS.UsedRange.Copy xMasterWS.Cells(Last_Row, 3)
                Last_Row = xMasterWS.Cells(Rows.Count, 3).End(xlUp).Row + 1
            Next xWS
            Workbooks(xStrAWBName).Close
            xStrFName = Dir()
        Loop
        
        For Each r In xMasterWS.Range("A2:B" & Last_Row - 1)
            If r.Value = "" Then r.FillDown
        Next r
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        
    End Sub

  7. #7
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    Hi,

    Request if someone can look at the below code and advice what is wrong with the code. It is working, but in some cases I' getting the following error

    error.jpg

    Option Explicit
    
    
    Sub MergeWorkbooks()
        Dim xStrPath As String
        Dim xStrFName As String
        Dim xWS    As Worksheet
        Dim xCopyWS   As Worksheet
        Dim xMasterWB   As Workbook
        Dim xMasterWS   As Worksheet
        Dim Last_Row As Long, Last_Column As Long, Coulmn_Number As String
        Dim xStrAWBName As String
        Dim Check  As Boolean
        Dim r      As Range
    
    
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            .Title = "Choose the location of excel files to merge"
            If .SelectedItems.Count = 1 Then
                xStrPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
        
        xStrFName = Dir(xStrPath & "\*.xl*")
        
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        
        Workbooks.Add
        ActiveWorkbook.SaveAs Filename:=xStrPath & "\" & "Combined.xlsx"
        
        Set xMasterWB = Workbooks("Combined.xlsx")
        xMasterWB.Sheets(1).Name = "Combined"
        Set xMasterWS = xMasterWB.Sheets("Combined")
        Last_Row = 1
        
        With xMasterWS.Range("A1")
            .Value = "WorkBook Name"
            .Interior.ColorIndex = 36
        End With
        
        Do While Len(xStrFName) > 0
            
            Workbooks.Open Filename:=xStrPath & "\" & xStrFName, ReadOnly:=True
            xStrAWBName = ActiveWorkbook.Name
            For Each xWS In ActiveWorkbook.Sheets
                If Not (xWS.Name = "SQL Statement") Then
                    xMasterWS.Cells(Last_Row + 1, 1) = xStrAWBName
                    xWS.UsedRange.Copy xMasterWS.Cells(Last_Row, 2)
                    Last_Row = xMasterWS.Cells(Rows.Count, 2).End(xlUp).Row + 1
                End If
            Next xWS
            Workbooks(xStrAWBName).Close
            xStrFName = Dir()
        Loop
        
        With xMasterWS
            
    ' Fill workbook name down in blank cells
            For Each r In .Range("A2:A" & Last_Row - 1)
                If r.Value = "" Then r.FillDown
            Next r
    
    ' Delete column headings copied from other WS and WB
            On Error Resume Next
            .Range("A1:" & Coulmn_Number & Last_Row - 1).AutoFilter Field:=2, Criteria1:=.Range("B1").Value
            .Range("A1:" & Coulmn_Number & Last_Row - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilterMode = False
            On Error GoTo 0
            
        End With
        xMasterWB.Save
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        
    End Sub
    Last edited by anish.ms; 04-11-2021 at 06:24 AM.

  8. #8
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    Please ignore the above request. I got a different version to combine many workbooks in to one worksheet.
    Posted here as may be useful for some new members.

    Option Explicit
    
    
    Sub CombineWorkbooks()
        Dim strDirContainingFiles As String, strFile As String, strFilePath As String
        Dim wbkDst As Workbook, wbkSrc As Workbook
        Dim wksDst As Worksheet, wksSrc As Worksheet, xWS As Worksheet
        Dim lngIdx As Long, lngSrcLastRow As Long, _
            lngSrcLastCol As Long, lngDstLastRow As Long, _
            lngDstLastCol As Long, lngDstFirstFileRow As Long
        Dim rngSrc As Range, rngDst As Range, rngFile As Range
        Dim t0     As Double
        Dim colFileNames As Collection
        Set colFileNames = New Collection
        
        
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Please select a folder"
            .Show
            .AllowMultiSelect = False
            If .SelectedItems.Count = 0 Then
                MsgBox "You did not select a folder."
                Exit Sub
            End If
            strDirContainingFiles = .SelectedItems(1) & "\"
        End With
        
        Set wbkDst = Workbooks.Add                    '<~ Dst is short for destination
        Set wksDst = wbkDst.ActiveSheet
        
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            .Calculation = xlCalculationManual
        End With
        
        'Store all of the file names in a collection
        strFile = Dir(strDirContainingFiles & "\*.xl*")
        Do While Len(strFile) > 0
            colFileNames.Add Item:=strFile
            strFile = Dir
        Loop
        
        'Let the user know the number of excel files in the selected folder!
        If colFileNames.Count = 0 Then
            MsgBox "Hi " & Application.UserName & vbNewLine & vbNewLine _
                 & "There are no excel files in this folder."
            wbkDst.Close
            Exit Sub
        Else
            MsgBox "Hi " & Application.UserName & vbNewLine & vbNewLine _
                 & "There are " & colFileNames.Count & " excel files in this folder." & vbNewLine & _
                   "All these files will be combined."
        End If
        
        t0 = CDbl(Now())
        
        'Now we can start looping through the "source" files
        'and copy their data to our destination sheet
        For lngIdx = 1 To colFileNames.Count
            
            'Assign the file path
            strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)
            
            'Open the workbook and store a reference to the data sheet
            Set wbkSrc = Workbooks.Open(strFilePath)
            
            For Each xWS In wbkSrc.Sheets
                If Not (xWS.Name = "SQL Statement") Then
                    
                    Set wksSrc = wbkSrc.Worksheets(xWS.Name) '<~ change based on your Sheet name
                    
                    'Identify the last row and last column, then
                    'use that info to identify the full data range
                    lngSrcLastRow = LastOccupiedRowNum(wksSrc)
                    lngSrcLastCol = LastOccupiedColNum(wksSrc)
                    With wksSrc
                        If lngIdx = 1 And xWS.Index = 1 Then
                            Set rngSrc = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, lngSrcLastCol))
                        Else
                            Set rngSrc = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, lngSrcLastCol))
                            Set rngSrc = rngSrc.Offset(1, 0).Resize(rngSrc.Rows.Count - 1)
                        End If
                    End With
                    
                    'Copy the source data to the destination sheet, aiming
                    'for cell A1 on the first loop then one past the
                    'last-occupied row in column A on each following loop
                    If lngIdx = 1 And xWS.Index = 1 Then
                        lngDstLastRow = 1
                        Set rngDst = wksDst.Cells(1, 1)
                        
                    Else
                        lngDstLastRow = LastOccupiedRowNum(wksDst)
                        Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
                    End If
                    rngSrc.Copy Destination:=rngDst   '<~ this is the copy / paste
                    
                    'Almost done! We want to add the source file info
                    'for each of the data blocks to our destination
                    
                    'On the first loop, we need to add a "Source Filename" column
                    If lngIdx = 1 And xWS.Index = 1 Then
                        lngDstLastCol = LastOccupiedColNum(wksDst)
                        wksDst.Cells(1, lngDstLastCol + 1) = "Source Filename"
                    End If
                    
                    'Identify the range that we need to write the source file
                    'info to, then write the info
                    With wksDst
                        
                        'The first row we need to write the file info to
                        'is the same row where we did our initial paste to
                        'the destination file
                        lngDstFirstFileRow = lngDstLastRow + 1
                        
                        'Then, we need to find the NEW last row on the destination
                        'sheet, which will be further down (since we pasted more
                        'data in)
                        lngDstLastRow = LastOccupiedRowNum(wksDst)
                        lngDstLastCol = LastOccupiedColNum(wksDst)
                        
                        'With the info from above, we can create the range
                        Set rngFile = .Range(.Cells(lngDstFirstFileRow, lngDstLastCol), _
                        .Cells(lngDstLastRow, lngDstLastCol))
                        
                        'Now that we have that range identified,
                        'we write the file name
                        rngFile.Value = wbkSrc.Name
                    End With
                End If
            Next xWS
            'Close the source workbook and repeat
            wbkSrc.Close savechanges:=False
            
            With wksDst
                DoEvents
                Application.StatusBar = "Combining Workbooks in to one Worksheet : " _
                                      & Format(lngIdx / colFileNames.Count, "0.00%")
            End With
            
        Next lngIdx
        wksDst.Cells(1).EntireRow.Columns.AutoFit
        
        With Application
            .ScreenUpdating = True
            .DisplayAlerts = True
            .Calculation = xlCalculationAutomatic
            .StatusBar = False
        End With
        
        'Let the user know that the combination is done!
        MsgBox Format(Now - t0, "hh:mm:ss"), vbInformation, "Completed!"
        
    End Sub
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'INPUT       : Sheet, the worksheet we'll search to find the last row
    'OUTPUT      : Long, the last occupied row
    'SPECIAL CASE: if Sheet is empty, return 1
    Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
        Dim lng    As Long
        If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
            With Sheet
                lng = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
            End With
        Else
            lng = 1
        End If
        LastOccupiedRowNum = lng
    End Function
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'INPUT       : Sheet, the worksheet we'll search to find the last column
    'OUTPUT      : Long, the last occupied column
    'SPECIAL CASE: if Sheet is empty, return 1
    Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
        Dim lng    As Long
        If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
            With Sheet
                lng = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Column
            End With
        Else
            lng = 1
        End If
        LastOccupiedColNum = lng
    End Function
    Last edited by anish.ms; 04-13-2021 at 10:35 AM.

Posting Permissions

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