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

Code:

---

xStrPath = "C:\Users\anish.ms\Desktop\Sample\"
xStrFName = Dir(xStrPath & "*.xlsx")

---

Option - 2

Code:

---

xStrPath = Application.FileDialog(msoFileDialogFolderPicker).Show
xStrFName = xStrPath & "*.xlsx"

---

Code:

---


'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

Define "not working"


Didn't test WS copy code

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

---

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?

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

Thanks Paul! that's a great option.

I have done below for the time being

Code:

---

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

I have modified the code as below to copy each WS from each WB and paste in one WS

Code:

---

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

---

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

Attachment 28283

Code:

---

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

---

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.

Code:

---

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

---