Moving Files Based on Last Modified Date

[rsleedy]

I want to move a lot of files and folders (1,000s of files in 100s of folders) based on their last modified date. I found a nice piece of code at this site that moves files from the folders that are "hard coded" as strings e.g.

strSourceFolder = "C:\test_start\test files"

The code moves through the folder and looks at the date and moves the files appropriately. The thing I don't know how to do is make the code look at all the sub folders.

Ultimately I would like to code in a top directory, in the above example C:\test_start, and have the code go through, move the files and create the folder paths as required.

Thanks in advance for any help, as well as the code I snagged already.

[patel]

You have a code, why did you not attach it ?

[rsleedy]

Here is the complete code set I have thus far.
Sub Move_Files_To_New_Folder()
''This procedure will copy/move all files in a folder to another specified folder'''
''Can be easily modified
Dim objFSO As FileSystemObject, objFolder As Folder, PathExists As Boolean
Dim objFile As File, strSourceFolder As String, strDestFolder As String
Dim x, Counter As Integer, Overwrite As String
Application.ScreenUpdating = False 'turn screenupdating off
'Application.EnableEvents = False 'turn events off
'identify path names below:
strSourceFolder = "C:\test_start\test files" 'Source path
strDestFolder = "C:\test_end" 'destination path, does not have to exist prior to execution
''''''''''NOTE: Path names can be strings built in code, cell references, or user form text box strings''''''
''''''''''example: strSourceFolder = Range("A1")
'below will verify that the specified destination path exists, or it will create it:
On Error Resume Next
x = GetAttr(strDestFolder) And 0
If Err = 0 Then 'if there is no error, continue below
PathExists = True 'if there is no error, set flag to TRUE
Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
"Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
'message to alert that you may overwrite files of the same name since folder exists
If Overwrite <> vbYes Then Exit Sub 'if the user clicks YES, then exit the routine..
Else: 'if path does NOT exist, do the next steps
PathExists = False 'set flag at false
If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one
End If 'end the conditional testing
On Error GoTo ErrHandler
Set objFSO = New FileSystemObject 'creates a new File System Object reference
Set objFolder = objFSO.getFolder(strSourceFolder) 'get the folder
Counter = 0 'set the counter at zero for counting files copied
If Not objFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section
For Each objFile In objFolder.Files 'for every file in the folder...
'Below: If statements can be used to evaluate parts of file name for file type,
'or using the InStr method below, can identify parts of a file name to conditionally
'copy files based on any part of the file name. For non-extension checks, replace
'what is inside the " " to check for that within the file name.
'If InStr(1, objFile.Name, ".xls") Then ' Will copy only Excel files
'If InStr(1, objFile.Name, ".txt") Then ' Will copy only Text files
'objFile.Copy strDestFolder & "\" & objFile.Name 'use the destination path string, add a / separator and the file name
If objFile.DateLastModified < "06/01/2012" Then
objFile.Move strDestFolder & "\" & objFile.Name 'Syntax for MOVING file only, remove the ' to use
Counter = Counter + 1 'increment a count of files copied
End If 'where conditional check, if applicable would be placed.
' Uncomment the If...End If Conditional as needed
Next objFile 'go to the next file
MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
" copied/moved to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!"
'Message to user confirming completion
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Exit Sub
NoFiles:
'Message to alert if Source folder has no files in it to copy
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
'Application.EnableEvents = True 'turn events back on
Exit Sub 'exit sub here to avoid subsequent actions
ErrHandler:
'A general error message
MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
"Please verify that all files in the folder are not currently open," & _
"and the source directory is available"
Err.Clear 'clear the error
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
'Application.EnableEvents = True 'turn events back on
End Sub

[rsleedy]

I suspect the answer will in the form of a function, to go through the folders and return a string for each path, but I am not savy enough to write it....

[rsleedy]

That code didn't post very cleanly, here is a txt file with the code.

[patel]

try this
Sub Move_Files_To_New_Folder()
Dim PathExists As Boolean
Dim strSourceFolder As String, strDestFolder As String
Dim x, Counter As Integer, Overwrite As String
strSourceFolder = "C:\test_start\test files" 'Source path
strDestFolder = "C:\test_end" 'destination path, does not have to exist prior to execution
x = GetAttr(strDestFolder) And 0
If Err = 0 Then '
PathExists = True
Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
"Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
If Overwrite <> vbYes Then Exit Sub
Else
PathExists = False
MkDir (strDestFolder)
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder
Counter = 0 'set the counter at zero for counting files copied
If Not objFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section
For Each objFile In objFolder.Files
If objFile.DateLastModified < "06/01/2012" Then
objFile.Move strDestFolder & "\" & objFile.Name
Counter = Counter + 1
End If
Next objFile
Set sf = objFolder.subfolders
For Each f1 In sf
For Each fil In f1.Files
If fil.DateLastModified < "06/01/2012" Then
fil.Move strDestFolder & "\" & fil.Name
Counter = Counter + 1
End If
Next fil
Next f1

MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
" copied/moved to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Exit Sub
NoFiles:
'Message to alert if Source folder has no files in it to copy
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Exit Sub 'exit sub here to avoid subsequent actions
End Sub

[snb]

Please keep it simple:


Sub snb()
c00 = "G:\OF\"
c01 = "G:\old\"

If Dir(c01, 16) = "" Then MkDir c01

sn = Split(CreateObject("wscript.shell").exec("cmd /c dir G:\OF\*.csv /b /s /o-d").stdout.readall, vbCrLf)
For j = 1 To UBound(sn)
If DateDiff("d", FileDateTime(sn(j)), Date) > 30 Then Exit Sub
Name sn(j) As c01 & Dir(sn(j))
Next
End Sub



This code looks in folder G:\OF & it's subfolders for all .csv files, sorted by date (descending).
If the last time a file has been saved lays within 30 days from today it will be moved to folder G:\Old.

[rsleedy]

I guess I oversimplified my problem statement in the original post. I am relocating a bunch of files from one server location to another. Some of these files are stored six or more folders deep (see example). I want to move all files with a modified date of 7 years ago as of 12/31/2012 to a new location on the servers while maintaining their original folder path from the sixth folder on down (10902). For example the files located at P:\QUALITY\Quality_Assurance\Dept 54 3D Measurements\Space\10902 that are older than the 7 year date will be moved to P:\QUALITY\3dGroup\ToBeArchived\10902. Any files that are “younger” than the 7 years will be moved to P:\QUALITY\3dGroup\Measurements\10902.
The first portion of the from file path - P:\QUALITY\Quality_Assurance\Dept 54 3D Measurements\ will be constant. Same for the firs portion of the to location(s) the P:\QUALITY\3dGroup\ will be a constant.
In my original post I don’t think I was stating the whole problem of the multi-level folders, sorry for the confusion.

[snb]

Be smart: copy the whole lot to the new server in 1 go.
Delete the files you want to get rid off on the originating server, using my adapted code.

[SamT]

Torantis (http://www.vbaexpress.com/forum/member.php?67177-Torantis)


Your question and replies to it were moved to

http://www.vbaexpress.com/forum/showthread.php?62382-Moving-Files-amp-Folders-by-Last-Modified-Date