Public Sub ResetApplicationSettings(ByVal bl As Boolean)
Application.ScreenUpdating = bl
Application.Calculation = bl
Application.DisplayAlerts = bl
Application.Calculation = IIf(bl, xlCalculationAutomatic, xlCalculationManual)
End Sub
Sub MergeExcelFiles()
ResetApplicationSettings False
On Error GoTo ErrorHandler
Dim wsNameDict As Object, FSO As Object, sourceFolder As Object, fileItem As Object
Dim currentWorkbook As Workbook, sourceWorkbook As Workbook
Dim sourceSheets() As Worksheet, ws As Variant
Dim newFilePath As String, wsName As String, bookName As String, folderPath As String
Dim wsNum As Integer, wsExist As Boolean
folderPath = "C:\supplierFile"
Set wsNameDict = CreateObject("Scripting.Dictionary")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set sourceFolder = FSO.GetFolder(folderPath)
Set currentWorkbook = Workbooks.Add
For Each ws In currentWorkbook.Worksheets
wsNameDict.Add ws.Name, 1
Next ws
For Each fileItem In sourceFolder.Files
bookName = fileItem.Name
If bookName Like "*.xls*" Then
Set sourceWorkbook = Workbooks.Open(fileItem.Path)
ReDim sourceSheets(1 To sourceWorkbook.Worksheets.Count) As Worksheet
For Each ws In sourceWorkbook.Worksheets
Set sourceSheets(ws.Index) = ws
Next ws
For Each ws In sourceSheets
If Not ws Is Nothing Then
wsExist = wsNameDict.Exists(ws.Name)
wsName = ws.Name: wsNum = 1
While wsExist
wsName = ws.Name & "_" & wsNum
wsNum = wsNum + 1
wsExist = wsNameDict.Exists(wsName)
Wend
ws.Copy After:=currentWorkbook.Sheets(currentWorkbook.Sheets.Count)
currentWorkbook.Sheets(currentWorkbook.Sheets.Count).Name = wsName
wsNameDict.Add wsName, 1
End If
Next ws
sourceWorkbook.Close False
End If
Next fileItem
bookName = "MergedFiles__" & Format(Now, "yyMMdd hhmmss") & "__.xlsx"
newFilePath = FSO.BuildPath(folderPath, bookName)
currentWorkbook.SaveAs Filename:=newFilePath, FileFormat:=51
currentWorkbook.Close SaveChanges:=False
ResetApplicationSettings True
MsgBox "The process has finished, please check the " & bookName & " file in the " & folderPath, vbInformation, "MergedFiles"
Exit Sub
ErrorHandler:
ResetApplicationSettings True
MsgBox Err.Description, vbCritical, "ErrorNumber:" & Err.Number
End Sub