Searching For Files on Drive and Excluding Certain Files

[pawest]

I'm searching for certain files on a specified, referenced drive in Worksheet("Parameters"). These files have to be last modified before a certain date and the search should not locate certain files in specified, referenced folders. The goal of this project is to collect "stale files," and, after I have collected them, move them, and delete them. I am not at the moving or deleting stages just yet. Please help with the following code:

Sub ListFiles()
On Error Resume Next
Sheets.Add
Call CreateList
Call MsgBeSure
End Sub
Sub CreateList()
Dim filePath As Variant, fsObject As Variant, file As Variant
Dim i As Long, Lastrow As Long
Dim Count As Integer
Lastrow = Worksheets("Parameters").Range("F65536").End(xlUp).Row
Set PFcell = Worksheets("Parameters").Cells(Count, 6)
With Application.FileSearch
.LookIn = Range("Drive")
.SearchSubFolders = Range("Include_Subfolders")
.Filename = "*.*"
.Execute

For Each filePath In .FoundFiles
i = 1 + i
Set fsObject = CreateObject("Scripting.FileSystemObject")
Set file = fsObject.GetFile(filePath)
ActiveSheet.Cells(i, 1) = file.Drive
ActiveSheet.Cells(i, 2) = file.Name
ActiveSheet.Cells(i, 3) = file.ParentFolder
For Count = 19 To Lastrow
If ActiveSheet.Cells(i, 3) = PFcell.Value Then
Exit Sub
End If
Next Count
ActiveSheet.Cells(i, 4) = file.Path
ActiveSheet.Cells(i, 5) = file.DateLastModified
If ActiveSheet.Cells(i, 5) = Worksheets("Parameters").Range("Before_Date").Value Then
Exit Sub
End If
Next filePath
.NewSearch

End With
End Sub
Sub MsgBeSure()
MsgBox "Do NOT move or delete gathered, stale data before consulting with your coworkers and supervisors and receiving their input. Be sure to sort and assess the gathered, stale data for file sequences or data that should not be deleted."
End Sub


... If I take out the:

For Count = 19 To Lastrow
If ActiveSheet.Cells(i, 3) = PFcell.Value Then
Exit Sub
End If
Next Count
and the...
If ActiveSheet.Cells(i, 5) = Worksheets("Parameters").Range("Before_Date").Value Then
Exit Sub
End If

... the macro works great. However, those are the most important features that I need. Since I'm searching through more than 100,000 using excel 2003, I cannot list all files within the given parameters. It has to be only the certain files that fall within the specified, referenced criteria.

Your help is appreciated!

 

[pawest]

The below code will show you where I have made improvements, but I'm still not quite there. I need to use left and right character references to find the files rather than referencing cells in other sheets. Here is where I'm at...

Sub ListFiles()
On Error Resume Next
Sheets.Add
Call CreateList
Call MsgBeSure
End Sub
Sub CreateList()
Dim filePath As Variant, fsObject As Variant, file As Variant
Dim i As Long, Lastrow As Long
Dim Count As Integer
Dim PFcell
Lastrow = Worksheets("Parameters").Range("F65536").End(xlUp).Row

With Application.FileSearch
.LookIn = Range("Drive")
.SearchSubFolders = Range("Include_Subfolders")
.Filename = "*.*"
.Execute

For Each filePath In .FoundFiles
i = 1 + i
Set fsObject = CreateObject("Scripting.FileSystemObject")
Set file = fsObject.GetFile(filePath)
If ActiveSheet.Cells(i, 5) <= Worksheets("Parameters").Range("Before_Date").Value Then

For Count = 19 To Lastrow
PFcell = Worksheets("Parameters").Cells(Count, 6).Value

'I realize that ActiveSheet... needs to be changed to specifying
'the exact characters referenced, due to the face that activesheet...
'references cells rather than characters. So, I will be using left and
'right commands to recognize the exact characters
If ActiveSheet.Cells(i, 3) = PFcell Then
flag = 1
Exit For
End If
Next Count

If flag <> 1 Then

ActiveSheet.Cells(i, 1) = file.Drive
ActiveSheet.Cells(i, 2) = file.Name
ActiveSheet.Cells(i, 3) = file.ParentFolder
ActiveSheet.Cells(i, 4) = file.Path
ActiveSheet.Cells(i, 5) = file.DateLastModified

End If

End If
Next filePath
.NewSearch

End With
End Sub
Sub MsgBeSure()
MsgBox "Do NOT move or delete gathered, stale data before consulting with your coworkers and supervisors and receiving their input. Be sure to sort and assess the gathered, stale data for file sequences or data that should not be deleted."
End Sub


Thank you for your consideration to help!

 

[pawest]

I figured it out... well with a lot of help from a programmer where I work! Now I have to move files and delete the old, stale files... I think I know how to do that though.

Sub ListFiles()
On Error Resume Next
Call CreateList
Call MsgBeSure
End Sub
Sub CreateList()
Sheets.Add
Dim filePath As Variant, fsObject As Variant, file As Variant
Dim i As Long, Lastrow As Long
Dim Count As Integer
Dim PFcell
Lastrow = Worksheets("Parameters").Range("F65536").End(xlUp).Row
With Application.FileSearch
.LookIn = Range("Drive")
.SearchSubFolders = Range("Include_Subfolders")
.Filename = "*.*"
.Execute

For Each filePath In .FoundFiles
Set fsObject = CreateObject("Scripting.FileSystemObject")
Set file = fsObject.GetFile(filePath)

'***The date of the file should be earlier than preset date****

If file.DateLastModified <= Worksheets("Parameters").Range("Before_Date").Value Then
For Count = 19 To Lastrow
PFcell = Worksheets("Parameters").Cells(Count, 6).Value

If Left(file.ParentFolder, Len(PFcell)) = PFcell Then
' If file.ParentFolder = Left(PFcell, Len(PFcell)) & "*" Then

GoTo 0
' End If
End If

Next Count
i = 1 + i
ActiveSheet.Cells(i, 1) = file.Drive
ActiveSheet.Cells(i, 2) = file.Name
ActiveSheet.Cells(i, 3) = file.ParentFolder
ActiveSheet.Cells(i, 4) = file.Path
ActiveSheet.Cells(i, 5) = file.DateLastModified

End If
0 Next filePath
.NewSearch


End With
End Sub
Sub MsgBeSure()
MsgBox "Do NOT move or delete gathered, stale data before consulting with your coworkers and supervisors and receiving their input. Be sure to sort and assess the gathered, stale data for file sequences or data that should not be deleted."
End Sub