Rick you are correct, I started looking into the other modules and here is
the complete code for the othe subs that are being called:
Sub RDB_Copy_Sheet()
Dim myFiles As Variant
Dim myCountOfFiles As Long
myCountOfFiles = Get_File_Names( _
MyPath:="H:\myprojdir\GWIS\Humble\Test\part2", _
Subfolders:=True, _
ExtStr:="*.xl*", _
myReturnedFiles:=myFiles)
If myCountOfFiles = 0 Then
MsgBox "No files that match the ExtStr in this folder"
Exit Sub
End If
Get_Sheet _
PasteAsValues:=True, _
SourceShName:="Report*", _
SourceShIndex:=1, _
myReturnedFiles:=myFiles
End Sub
' Note: You not have to change the macro below, you only
' edit and run the RDB_Copy_Sheet above.
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
--------------------------------
Option Explicit
Private myFiles() As String
Private Fnum As Long
Function Get_File_Names(MyPath As String, Subfolders As Boolean, _
ExtStr As String, myReturnedFiles As Variant) As Long
Dim Fs
bj 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 Fs
bj = CreateObject("Scripting.FileSystemObject")
Erase myFiles()
Fnum = 0
'Test if the folder exist and set RootFolder
If Fs
bj.FolderExists(MyPath) = False Then
Exit Function
End If
Set RootFolder = Fs
bj.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
