Merge Workbooks into one - Help in Folder Picker

[anish.ms]

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

[Paul_Hossler]

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

[anish.ms]

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?

[Paul_Hossler]

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

[anish.ms]

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

[anish.ms]

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

[anish.ms]

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

28283


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

[anish.ms]

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