試圖找到MS Excel/VBA代碼以將lastdate修改後的所有子文件夾<日期-30移至不同的文件夾。基於最後修改日期移動子文件夾
這樣的（但顯然不是這樣）
foldertomove = subfolder
folder = main
newfolder = archive
for each subfolder in main
if subfolder.datelastmodified < date - 30 then
move subfolder to archive
end if
next
任何幫助，不勝感激！謝謝！
私人小組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
輸出的快照位於下方。 
本計劃的進一步改進應根據專家的反饋和幫助進行努力。代碼放在下面。
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
非常感謝，@skkakkar，這真的幫助了我！它似乎沒有複製任何地方，但我可以使用您的代碼創建的列表來重命名/移動每個子文件夾。我不知道這是否可以做到最有效的方式，但它是有效的。由於其他我最終做的事情，我從你的代碼中註釋掉了不需要的東西。我會在下面發表我的回答。再次感謝！ –
@Joe Patrick我很驚訝它沒有複製。我經過徹底的測試後才發佈。它適用於我按照過程概述檢查日期。這個程序基本的東西是相同的空結構應該預先存在。否則，可以修改它以創建根目錄並將文件轉儲到單個根文件夾中。 – skkakkar
@Joe Patrick請參閱上傳的快照[這裏]（https://www.dropbox.com/s/r46upj17hyvtp9f/ice_screenshot_20160528-104532.jpeg?dl=0）程序按照程序中列出的指令進行處理。 – skkakkar
想出了一個更直接的方式來獲得需要歸檔的子文件夾：
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
請參考[複製和移動文件和文件夾] （http://www.rondebruin.nl/win/s3/win026.htm）。它涵蓋了與日期有關的文件的移動。您必須使用文件系統對象（FSO）。 – skkakkar
hi @skkakkar，我發現，但它只覆蓋一次移動一個文件夾。它還涵蓋了一次移動多個文件但不包含文件夾。我嘗試過（勇敢地，我覺得）適應我的需求，但無法弄清楚。有人可以幫忙嗎？ –
是否要移動文件夾及其文件，並且只有一層子文件夾嵌套，即沒有文件夾層次結構。如果有文件夾層次結構，則需要遞歸循環。進一步請注意，我總是喜歡複製而不是移動。如果在目標文件夾中存在具有相同名稱的文件，或者存在目錄權限問題，則可能會發生意外錯誤。在這種情況下，合作關係已經發生了變化，並且不需要嚴格的檢查。複製是安全的，因爲您的原始文件夾完好無損，可以在成功移動後刪除。 – skkakkar