Cataloging & Specifying Old Files, Moving them, & Deleting Them

[pawest]

Dear MrExcel Experts,

I am an intern trying to catalog over 100K old files. I am using a main worksheet to specify the parameters of what files I need. The parameters include specifying which drive I want to search, if I want to include Subfolders, specifying a date to gather files prior to, and specifying folders not to search. The code references cells from a main worksheet and adds the gathered files to a new sheet. HEre is the code I have so far:

Sub ListFiles2()
On Error Resume Next
Call Setup2
Call CreateList
End Sub

Sub CreateList()
Dim filePath As Variant, fsObject As Variant, file As Variant
Dim i As Long
With Application.FileSearch
.LookIn = "C:\Documents and Settings\pawest\My Documents\"
.SearchSubFolders = True
.Filename = "*.*"
.Execute
For Each filePath In .FoundFiles
i = i + 1
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
ActiveSheet.Cells(i, 4) = file.Path
ActiveSheet.Cells(i, 5) = file.DateLastModified
Next filePath
.NewSearch
End With
End Sub

Sub Setup2()
Sheets.Add
Cells(1, 1) = "Drive"
Cells(1, 2) = "File Name"
Cells(1, 3) = "Parent Folder"
Cells(1, 4) = "Path"
Cells(1, 5) = "Date Last Modified"
Range("A1:E1").Font.Bold = True
End Sub

I know how to reference a cell to search a drive and I know how to reference a cell to searchsubfolders. But now I need to make it so it can reference cells from the worksheet using loops to specify a date in the past in which I want to search for old files and then multiple cells that include multiple folders for which not to search. I have used multipe If-Then, and Select Case loops, but I am a novice VBA user and nothing seems to work. I am using EXCEL 2003 by the way.

After I have completed this code. I will need to also move the files and then delete the files from their previous location. Any insight would be much appreciated! Thanks!

 

[pawest]

Re: Cataloging Old Files, Moving them, and Deleting Them

Here is what I have come up with and I would greatly appreciate it if anyone could take a look at where I went wrong:

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
Dim Lastrow As Long
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)
ActiveSheet.Cells(i, 1) = file.Drive
ActiveSheet.Cells(i, 2) = file.Name
ActiveSheet.Cells(i, 3) = file.ParentFolder
For Counter = 18 To Lastrow
Set PFcell = Worksheets("Parameters").Cells(Counter, 6)
If PFcell.Value = file.ParentFolder Then Exit Sub
Next Counter
ActiveSheet.Cells(i, 4) = file.Path
ActiveSheet.Cells(i, 5) = file.DateLastModified
If file.DateLastModified >= Worksheets("Parameters").Range("Before_Date").Value Then Exit Sub
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


Code:
Sub Move_Rename_Folder()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim Lastrow As Long

Lastrow = Worksheets("Sheet3").Range("D65536").End(xlUp).Row
If MsgBox("Are you sure you want to move all gathered, stale files?", vbYesNo) <> vbYes Then Exit Sub
If MsgBox("Are you sure you want to move all gathered, stale files?", vbYesNo) = vbYes Then
For Counter = 1 To Lastrow
Set Pathcell = Worksheets("Sheet3").Cells(Counter, 4)
FromPath = Worksheets("Sheet3").Cells(Counter, 4)
ToPath = Worksheets("Parameters").Range("Drive").Value & "Stale Files" & Left(FromPath, Len(FromPath) - 2)
' If Right(FromPath, 1) = "\" Then
' FromPath = Left(FromPath, Len(FromPath) - 1)
' End If
'
' If Right(ToPath, 1) = "\" Then
' ToPath = Left(ToPath, Len(ToPath) - 1)
' End If
Set FSO = CreateObject("scripting.filesystemobject")
' If FSO.FolderExists(ToPath) = True Then
' MsgBox ToPath & " exist, not possible to move to a existing folder"
' Exit Sub
' End If
FSO.MoveFolder Source:=FromPath, Destination:=ToPath
Next Counter
End If

End Sub

Code:
Sub Delete_Files()
Dim Lastrow As Long
Lastrow = Worksheets(Range("Sheet_Name")).Range("D65536").End(xlUp).Row

If MsgBox("Are you sure you want to delete all gathered, stale files?", vbYesNo) <> vbYes Then Exit Sub
If MsgBox("Are you sure you want to delete all gathered, stale files?", vbYesNo) = vbYes Then
For Counter = 1 To Lastrow
Set StaleCell = Worksheets(Range("Sheet_Name")).Cells(Counter, 4)
Kill StaleCell
Next Counter

End Sub


There are many issues with this code. It references cells on pages which I have not explained in much but am assuming one can figure out. I would appreciate any help.

 

[pawest]

The below code will show you where I have made improvements, but I'm still not quite there. This post has been updated and look for another post by me called "Searching for files on drive and excluding certain files" for a better update...

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]

... in regard to this post and others I recently posted to be more clear...
The below code will show you where I have made improvements, but I'm still not quite there. This post has been updated and look for another post by me called "Searching for files on drive and excluding certain files" for a better update...

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

 

[pawest]

Now that I have figured out how to collect the files the way I would like. I am now stuck on coping the files to a new location. I tried many different ways and I've narrowed it down to 3 possibilities. I will post them all here to see if anyone can figure out what I'm doing wrong. Your consideration is appreciated.

Sub Copy_Rename_File1()
Dim FromPath As String, ToPath As String
Dim Lastrow As Long, i As Long
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
If MsgBox("Are you sure you want to move all stale files?", vbYesNo) <> vbYes Then
Exit Sub
End If

For i = 1 To Lastrow
FromPath = ActiveSheet.Cells(i, 4).Value
ToPath = ActiveSheet.Cells(i, 3).Value & "\Stale Files\" & ActiveSheet.Cells(i, 2).Value

'Name FromPath As ToPath
'The Name Fr.... is my first option
'Below is my second option
FileCopy Source:=FromPath, Destination:=ToPath

Next i

End Sub



Sub Copy_Rename_File2()
Dim fsObject As Variant
Dim FromPath As String, ToPath As String
Dim Lastrow As Long
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
If MsgBox("Are you sure you want to move all stale files?", vbYesNo) <> vbYes Then
Exit Sub
End If

For i = 1 To Lastrow
fsObject = CreateObject("Scripting.FileSystemObject")
FromPath = ActiveSheet.Cells(i, 4).Value
ToPath = ActiveSheet.Cells(i, 3).Value & "\Stale Files\" & ActiveSheet.Cells(i, 2).Value

fsObject.Copy FromPath, ToPath

Next i

End Sub




Sub Copy_Rename_File3()
Dim x As Variant
Dim i As Long
If MsgBox("Are you sure you want to move all stale files?", vbYesNo) <> vbYes Then
Exit Sub
End If
For Each x In ActiveSheet.Cells(Rows.Count, 1)
Name ActiveSheet.Cells(i, 4).Value As ActiveSheet.Cells(i, 3).Value & "\Stale Files\" & ActiveSheet.Cells(i, 2).Value
Next
End Sub



I appreciate your consideration in looking into this issue.