Question

尝试查找MS Excel / VBA代码以使用lastdatemodified移动所有子文件夹＆lt;日期-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

非常感谢任何帮助！谢谢！

Answer 1

此程序的目标是复制文件夹，子文件夹和文件夹在文件夹中以及其中包含的文件。它可以是任何类型的文件PDF，文本，Word，Excel等。
此程序只会复制30天以上的文件当前时间。用户可以根据需要调整此日期或两个日期之间他的要求。
程序运行时，文件选择器对话框将打开并允许用户访问选择要存档的文件夹。
空目录结构与此相同非常重要创建了要归档的父文件夹的文件夹结构。目前，此步骤的VBA代码尚未包含在内程序。最简单的方法是复制粘贴文件夹，然后删除文件手动在各种文件夹和子文件夹中。这是一次性运动只要父目录结构保持不变。任何变化在父目录结构中也要包含在存档文件夹也。
程序还将单独输出目录和文件路径正在存档的父目录的工作簿。如果不是然后需要对程序的相关部分进行注释。

输出快照位于下方。

应根据专家的反馈和帮助，进一步改进该计划。代码放在下面。

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

想出一个更直接的方法来获取需要归档的子文件夹：

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

根据上次修改日期移动子文件夹

3 个答案: