Does anyone know how to get the data from all subdirectories of
c:\audit\contractors\ ???
I have to sleep and work <vbg>
Try this one
Sub FSO_Example_1()
Dim SubFolders As Boolean
Dim Fso_Obj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object
Dim RootPath As String, FileExt As String
Dim MyFiles() As String, Fnum As Long
Dim rng As Range, str As String
Dim rnum As Long
Dim basebook As Workbook, mybook As Workbook
'Loop through all files in the Root folder
RootPath = "C:\audit"
'Loop through the subfolders True or False
SubFolders = True
'Loop through files with this extension
FileExt = ".xls"
'Add a slash at the end if the user forget it
If Right(RootPath, 1) <> "\" Then
RootPath = RootPath & "\"
End If
Set Fso_Obj = CreateObject("Scripting.FileSystemObject")
If Not Fso_Obj.FolderExists(RootPath) Then
MsgBox RootPath & " Not exist"
Exit Sub
End If
Set RootFolder = Fso_Obj.GetFolder(RootPath)
'Fill the array(myFiles)with the list of Excel files in the folder(s)
Fnum = 0
'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(Right(file.Name, 4)) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = RootPath & file.Name
End If
Next file
'Loop through the files in the Sub Folders if SubFolders = True
If SubFolders Then
For Each SubFolderInRoot In RootFolder.SubFolders
For Each file In SubFolderInRoot.Files
If LCase(Right(file.Name, 4)) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = SubFolderInRoot & "\" & file.Name
End If
Next file
Next SubFolderInRoot
End If
' Now we can open the files in the array MyFiles to do what we want
'******************************************************************
On Error GoTo CleanUp
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
str = Sheets("Sheet3").ComboBox1.Value
'Clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyFiles(Fnum))
rnum = LastRow(basebook.Worksheets("Sheet2")) + 1
With mybook.Sheets(1)
Set rng = Nothing
'Close AutoFilter first
.AutoFilterMode = False
'This example filter on column A for ron, Note: A1 is the Header cell
'Change the range and criteria to your Range/Criteria
.Range("B8:B400").AutoFilter Field:=1, Criteria1:=str
With .AutoFilter.Range
' Set a range without the Header cell
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'If there is data copy the rows
If Not rng Is Nothing Then
rng.EntireRow.Copy basebook.Worksheets("Sheet2").Cells(rnum, "A")
End If
End With
'Close AutoFilter
.AutoFilterMode = False
End With
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
