move subfolders based on date last modified - excel

Question

Trying to find MS Excel/VBA code to move all subfolders with lastdatemodified < date -30 to a different folder.
Like this (but obviously not this)
foldertomove = subfolder
folder = main
newfolder = archive
for each subfolder in main
if subfolder.datelastmodified < date - 30 then
move subfolder to archive
end if
next
Any help is greatly appreciated! Thanks!

Answer 1

Objective of this program is to Copy Folders, Sub-Folders and Folders
within Folders along with files contained in them. It could be any type of the file PDF, Text, Word, Excel etc.
This program will only copy Files which are 30 days older from
Current Time. User can adjust this date or between two dates as per
his requirements.
When program is run File Picker Dialog will open and allow user to
chose the folder to be archived.
It is very important that an Empty Directory Structure with same
folder structure as parent folder to be archived has is created.
Presently VBA code for this step has not been incorporated in this
program. Simplest way is to copy paste folder and then delete files
in various folders and sub-folders manually. It is one time exercise
so long as parent directory structure remains the same. Any changes
in the parent directory structure are also to be incorporated in the
Archive folder also.
Program will also output Directory and File Paths on a separate
workbook of the parent directory being archived. If it is not
required then relevant portions of the program can be commented out.
Snapshot of output is placed below.
Further improvements in this program shall be endeavoured based on feedback and help of experts.
Code is placed below.
Sub CopyFolders_Recursively()
Dim strFolder As String
Dim objFSO As Object
Dim objFolder As Object
Dim myResults As Variant
Dim lCount As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Get the directory from the user
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
'user cancelled
strFolder = .SelectedItems(1)
End With
Set objFolder = objFSO.GetFolder(strFolder)
'the variable dimension has to be the second one
ReDim myResults(0 To 5, 0 To 0)
' place make some headers in the array
myResults(0, 0) = "Filename"
myResults(1, 0) = "Size"
myResults(2, 0) = "Created"
myResults(3, 0) = "Modified"
myResults(4, 0) = "Accessed"
myResults(5, 0) = "Full path"
'Send the folder to the recursive function
FillFileList objFolder, myResults, lCount
' Dump these to a worksheet
fcnDumpToWorksheet myResults
'tidy up
Set objFSO = Nothing
End Sub
Private Sub FillFileList(objFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)
Dim i As Integer
Dim objFile As Object
Dim fsoSubFolder As Object
Dim fsoSubFolders As Object
Dim ToPath As String
Dim lpath As String
ToPath = "C:\Archive\"
Dim Fdtdiff As Integer
'load the array with all the files
For Each objFile In objFolder.Files
lCount = lCount + 1
ReDim Preserve myResults(0 To 5, 0 To lCount)
myResults(0, lCount) = objFile.Name
myResults(1, lCount) = objFile.Size
myResults(2, lCount) = objFile.DateCreated
myResults(3, lCount) = objFile.DateLastModified
myResults(4, lCount) = objFile.DateLastAccessed
myResults(5, lCount) = objFile.Path
Fdtdiff = DateValue(Now) - DateValue(myResults(3, lCount))
If Fdtdiff > 30 Then
lpath = Replace(objFile.Path, "my_dir", "Archive")
objFile.Copy lpath
End If
Next objFile
'recursively call this function with any subfolders
Set fsoSubFolders = objFolder.SubFolders
For Each fsoSubFolder In fsoSubFolders
FillFileList fsoSubFolder, myResults, lCount
Next fsoSubFolder
End Sub
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
Dim iSheetsInNew As Integer
Dim sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long
If mySh Is Nothing Then
'make a workbook if we didn't get a worksheet
iSheetsInNew = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = iSheetsInNew
Set sh = wb.Sheets(1)
Else
Set mySh = sh
End If
'since we switched the array dimensions, have to transpose
With sh
Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
Application.WorksheetFunction.Transpose(varData)
.UsedRange.Columns.AutoFit
End With
Set sh = Nothing
Set wb = Nothing
End Sub

Answer 2

Private Sub CopyFolders_Recursively()
Dim strFolder As String
Dim objFSO As Object
Dim objFolder As Object
Dim myResults As Variant
Dim lCount As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Get the directory from the user
'With Application.FileDialog(msoFileDialogFolderPicker)
'.Show
'If .SelectedItems.Count = 0 Then Exit Sub
'user cancelled
'strFolder = .SelectedItems(1)
'End With
strFolder = "D:\testing\" '<<change
Set objFolder = objFSO.GetFolder(strFolder)
'the variable dimension has to be the second one
ReDim myResults(0 To 5, 0 To 0)
' place make some headers in the array
myResults(0, 0) = "Filename"
myResults(1, 0) = "Size"
myResults(2, 0) = "Created"
myResults(3, 0) = "Modified"
myResults(4, 0) = "Accessed"
myResults(5, 0) = "Full path"
'Send the folder to the recursive function
FillFileList objFolder, myResults, lCount
' Dump these to a worksheet
fcnDumpToWorksheet myResults
CleanUpList
If Range("A2").Value = "" Then GoTo tidyup
AddFolders
Move_Folders
tidyup:
Cells.Delete
Range("A1").Select
'tidy up
Set objFSO = Nothing
End Sub
Private Sub FillFileList(objFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)
Dim i As Integer
Dim objFile As Object
Dim fsoSubFolder As Object
Dim fsoSubFolders As Object
Dim lpath As String
Dim Fdtdiff As Integer
'load the array with all the files
For Each objFile In objFolder.Files
If InStr(objFile.Path, "~Archive") = 0 Then 'don't get files from the archive folder (assumes the archive folder is a subfolder of the folder from which you're moving the other subfolders
lCount = lCount + 1
ReDim Preserve myResults(0 To 5, 0 To lCount)
myResults(0, lCount) = objFile.Name
myResults(1, lCount) = objFile.Size
myResults(2, lCount) = objFile.DateCreated
myResults(3, lCount) = objFile.DateLastModified
myResults(4, lCount) = objFile.DateLastAccessed
myResults(5, lCount) = objFile.Path
'Fdtdiff = DateValue(Now) - DateValue(myResults(3, lCount))
'If Fdtdiff > 30 Then
'lpath = Replace(objFile.Path, "my_dir", "~Archive")
'objFile.Copy lpath
'End If
End If
Next objFile
'recursively call this function with any subfolders
Set fsoSubFolders = objFolder.SubFolders
For Each fsoSubFolder In fsoSubFolders
FillFileList fsoSubFolder, myResults, lCount
Next fsoSubFolder
End Sub
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
'since we switched the array dimensions, have to transpose
With ThisWorkbook.Sheets(1) '<<change
Cells.ClearContents
Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
Application.WorksheetFunction.Transpose(varData)
.UsedRange.Columns.AutoFit
End With
End Sub
Private Sub CleanUpList()
'sort most recent files to the top so when we remove dupes we'll be left with the most recent one
ThisWorkbook.Worksheets("Archive").Sort.SortFields.Clear '<<change sheet name
ThisWorkbook.Worksheets("Archive").Sort.SortFields.Add Key:=Range("D2:D65536") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ThisWorkbook.Worksheets("Archive").Sort
.SetRange Range("A1:F65536")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'remove parent folder from path we'll check later
Columns("F:F").Replace What:="D:\testing\", Replacement:="", LookAt:=xlPart, MatchCase:=False '<< Change
'remove file name, leaving just the folder we want to move
Columns("F:F").Replace What:="\*", Replacement:="", LookAt:=xlPart, MatchCase:=False
'we just need one!
ThisWorkbook.Sheets(1).Range("$A$1:$AZ$65536").RemoveDuplicates Columns:=6, Header:=xlYes '<< remove dupes of folders to move
Set Rng = Range("D1:D100") '<< change if you know it will be less or more than 100
For Each cell In Rng
If cell.Value <> "" Then
If cell.Value > Date - 30 Then '<<only keep it if more than 30 days (or whatever you want)
cell.Value = ""
End If
End If
Next
On Error Resume Next
Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub
Private Sub AddFolders() 'we'll archive by year within the archive subfolder
Set Rng = Range("D2:D100") '<< change if you know it will be less or more than 100
For Each x In Rng
If x.Value <> "" Then
On Error Resume Next
MkDir "D:\testing\~Archive\" & Format(x.Value - 30, "yyyy") '<< Change
On Error GoTo 0
End If
Next x
End Sub
Private Sub Move_Folders()
'This example move the folder from FromPath to ToPath
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Set Rng = Range("F2:F100") '<< change if you know it will be less or more than 100
For Each x In Rng
If x.Value <> "" Then
FromPath = "D:\testing\" & x.Value '<< Change
ToPath = "D:\testing\~Archive\" & Format(x.Offset(0, -2).Value - 30, "yyyy") & "\" & x.Value '<< Change
'Note: It is not possible to use a folder that exist in ToPath
'We created subfolders by year earlier so we can archive by year now
Set FSO = CreateObject("scripting.filesystemobject")
FSO.MoveFolder Source:=FromPath, Destination:=ToPath
End If
Next x
End Sub

Answer 3

Figured out a more direct way to get the subfolders needed to be archived:
Private Sub Archive_Hotel_Confs()
Sheets("Archiving").Select
Cells.ClearContents
Dim strStartPath As String
strStartPath = "W:testing\" 'ENTER YOUR START FOLDER HERE
ListHCFolder strStartPath
CleanUpList
If Range("A1").Value = "" Then GoTo tidyup
AddHCFolders
MoveHC_Folders
'tidy up
tidyup:
Cells.Delete
Range("A1").Select
Sheets("Last Run").Select
End Sub
Private Sub ListHCFolder(sFolderPath As String)
Dim FS As New FileSystemObject
Dim FSfolder As Folder
Dim subfolder As Folder
Dim i As Integer
Set FSfolder = FS.GetFolder(sFolderPath)
For Each subfolder In FSfolder.SubFolders
If InStr(subfolder.Name, "~Archive") = 0 Then
DoEvents
i = i + 1
'added this line
Cells(i, 1) = subfolder
Cells(i, 2) = subfolder.DateLastModified
'commented out this one
'Debug.Print subfolder
End If
Next subfolder
Set FSfolder = Nothing
End Sub
Private Sub CleanUpList()
Dim x As Variant
'remove parent folder from path we'll check later
Columns("A:A").Replace What:="W:testing\", Replacement:="", LookAt:=xlPart, MatchCase:=False '<< Change
Set Rng = Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
For Each x In Rng
If x.Value <> "" Then
If x.Value > Date - 30 Then '<<only keep it if more than 30 days (or whatever you want)
x.Value = ""
End If
End If
Next x
On Error Resume Next
Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub
Private Sub AddHCFolders() 'we'll archive by year within the archive subfolder
Dim x As Variant
Set Rng = Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
For Each x In Rng
If x.Value <> "" Then
On Error Resume Next
MkDir "W:testing\~Archive\" & Format(x.Value - 30, "yyyy") '<< Change
On Error GoTo 0
End If
Next x
End Sub
Private Sub MoveHC_Folders()
'This example move the folder from FromPath to ToPath
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim x As Variant
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
For Each x In Rng
If x.Value <> "" Then
FromPath = "W:testing\" & x.Value '<< Change
ToPath = "W:testing\~Archive\" & Format(x.Offset(0, 1).Value - 30, "yyyy") & "\" & x.Value '<< Change
'Note: It is not possible to use a folder that exist in ToPath
'We created subfolders by year earlier so we can archive by year now
Set FSO = CreateObject("scripting.filesystemobject")
FSO.MoveFolder Source:=FromPath, Destination:=ToPath
End If
Next x
End Sub