Option Explicit
Private myFiles() As String
Private Fnum As Long
Sub Get_Sheet(PasteAsValues As Boolean, SourceShName As String, _
SourceShIndex As Integer, myReturnedFiles As Variant)
Dim mybook As Workbook, BaseWks As Worksheet
Dim CalcMode As Long
Dim SourceSh As Variant
Dim sh As Worksheet
Dim I As Long
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
On Error GoTo ExitTheSub
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Check if we use a named sheet or the index
If SourceShName = "" Then
SourceSh = SourceShIndex
Else
SourceSh = SourceShName
End If
'Loop through all files in the array(myFiles)
For I = LBound(myReturnedFiles) To UBound(myReturnedFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(myReturnedFiles(I))
On Error GoTo 0
If Not mybook Is Nothing Then
'Set sh and check if it is a valid
On Error Resume Next
Set sh = mybook.Sheets(SourceSh)
If Err.Number > 0 Then
Err.Clear
Set sh = Nothing
End If
On Error GoTo 0
If Not sh Is Nothing Then
sh.Copy after:=BaseWks.Parent.Sheets(BaseWks.Parent.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = mybook.Name
On Error GoTo 0
If PasteAsValues = True Then
With ActiveSheet.UsedRange
.Value = .Value
End With
End If
End If
'Close the workbook without saving
mybook.Close savechanges:=False
End If
'Open the next workbook
Next I
' delete the first sheet in the workbook
Application.DisplayAlerts = False
On Error Resume Next
BaseWks.Delete
On Error GoTo 0
Application.DisplayAlerts = True
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function Get_File_Names(MyPath As String, Subfolders As Boolean, _
ExtStr As String, myReturnedFiles As Variant) As Long
Dim Fso_Obj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create FileSystemObject object
Set Fso_Obj = CreateObject("Scripting.FileSystemObject")
Erase myFiles()
Fnum = 0
'Test if the folder exist and set RootFolder
If Fso_Obj.FolderExists(MyPath) = False Then
Exit Function
End If
Set RootFolder = Fso_Obj.GetFolder(MyPath)
'Fill the array(myFiles)with the list of Excel files in the folder(s)
'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(file.Name) Like LCase(ExtStr) Then
Fnum = Fnum + 1
ReDim Preserve myFiles(1 To Fnum)
myFiles(Fnum) = MyPath & file.Name
End If
Next file
'Loop through the files in the Sub Folders if SubFolders = True
If Subfolders Then
Call ListFilesInSubfolders(OfFolder:=RootFolder, FileExt:=ExtStr)
End If
myReturnedFiles = myFiles
Get_File_Names = Fnum
End Function
Sub ListFilesInSubfolders(OfFolder As Object, FileExt As String)
Dim SubFolder As Object
Dim fileInSubfolder As Object
For Each SubFolder In OfFolder.Subfolders
ListFilesInSubfolders OfFolder:=SubFolder, FileExt:=FileExt
For Each fileInSubfolder In SubFolder.Files
If LCase(fileInSubfolder.Name) Like LCase(FileExt) Then
Fnum = Fnum + 1
ReDim Preserve myFiles(1 To Fnum)
myFiles(Fnum) = SubFolder & "\" & fileInSubfolder.Name
End If
Next fileInSubfolder
Next SubFolder
End Sub
Function RDB_Last(choice As Integer, rng As Range)
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function
