Question

我试图让它从时间开始按升序排序，并且它不能正常工作。它添加了所有信息，但没有对值进行排序。另外，我需要添加一个截止值，因此它只会在当前日期的最后一周（7天）内上传文件。我不确定这是一种有效的方法。

谢谢！

Option Explicit
Sub ListFiles()

Application.ScreenUpdating = False
Sheets("Sheet2").Select 
With Range("A1")
    .Formula = "Folder contents:"
    .Font.Bold = True
    .Font.Size = 12
End With
Range("A3").Formula = "Folder Path:"
Range("B3").Formula = "File Name:"
Range("C3").Formula = "Creation Date:"

ListFolders "C:\Users\blake.rupprecht\Desktop\Photos\"

Application.ScreenUpdating = True

End Sub

Sub ListFolders(SourceFolderName As String)

Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim r As Long
Dim sfil As String
Dim par As String

Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)

On Error Resume Next
sfil = Dir(SourceFolderName & "\" & "*.jpg*")
Do Until sfil = ""
    Range("B" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveCell.Hyperlinks.Add ActiveCell, SourceFolderName & "\" & sfil, , , sfil
    ActiveCell.Offset(, 1).Value = SourceFolder.Files(sfil).DateCreated
    ActiveCell.Offset(1).Select
    sfil = Dir$
Loop

Columns("A:B").AutoFit

Set SourceFolder = Nothing
Set FSO = Nothing

End Sub

Answer 1

检查7天tmie span：

If Now - SourceFolder.Files(sfil).DateCreated < 7 Then
    Range("B" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveCell.Hyperlinks.Add ActiveCell, SourceFolderName & "\" & sfil, , , sfil
    ActiveCell.Offset(, 1).Value = SourceFolder.Files(sfil).DateCreated
    ActiveCell.Offset(1).Select
End If

请注意，计算也需要考虑时间。如果只想要日期，则必须从操作数中提取整数。

要对值进行排序，请记录一些排序，然后重新编译该代码以适合您的场景。

Answer 2

如果要按升序排序，最简单的方法可能是将结果添加到数组中，然后使用比较按升序重新排序数组，然后将值写入单元格中。阵列。当我回到办公室时，我会发一个例子。

代码未经测试，但应该有效。如果它没有，请告诉我，我会设置一个工作簿来测试它。另外，你可以将排序代码分解为它自己的功能，然后它可以重复使用其他惯例。按你的意愿做。

我删除了On Error Resume Next声明，因为在你拥有它的地方没有必要。关闭错误通知只会掩盖错误并使解决代码问题变得更加困难。如果你期望错误，写一些东西来处理它们，不要忽略它们。

Option Explicit

Sub ListFiles()

    Application.ScreenUpdating = False
    Sheets("Sheet2").Select
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A3").Formula = "Folder Path:"
    Range("B3").Formula = "File Name:"
    Range("C3").Formula = "Creation Date:"

    ListFolders "C:\Users\blake.rupprecht\Desktop\Photos\"

    Application.ScreenUpdating = True

End Sub

Sub ListFolders(SourceFolderName As String)

    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim r As Long
    Dim sfil As String
    Dim par As String
    Dim lngX As Long
    Dim lngY As Long
    Dim strX As String
    Dim strY As String
    Dim strTemp As String
    Dim strFiles() As String

    ReDim strFiles(0)
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

    sfil = Dir(SourceFolderName & "\*.jpg*")
        Do Until LenB(sfil) = 0
            If Now - SourceFolder.files(sfil).DateCreated < 7 Then
                    If lngX = 0 And LenB(strFiles(lngX)) = 0 Then
                        strFiles(0) = sfil
                    Else
                        ReDim Preserve strFiles(UBound(strFiles) + 1)
                        strFiles(UBound(strFiles)) = sfil
                    End If
            End If
        Loop


    'Sort the array in ascending order
    If LenB(srfiles(LBound(strFiles))) > 0 Then
            For lngY = 0 To UBound(strFiles) - 1
                    For lngX = 0 To UBound(strFiles) - 1
                    'Grab the current and next item in the list to compare
                        strX = strFiles(lngX)
                        strY = strFiles(lngX + 1)
                        'Check if the current item is greater than the next in the list and swap them if it is
                            If strX > strY Then
                                strTemp = strFiles(lngX)
                                strFiles(lngX) = strFiles(lngX + 1)
                                strFiles(lngX + 1) = strTemp
                            End If
                    'Reset the temporary strings so we don't accidentally use the wrong value in case of some unforeseen error
                        strTemp = vbNullString
                        strX = vbNullString
                        strY = vbNullString
                    Next lngX
            Next lngY
    End If


    For lngX = LBound(strFiles) To UBound(stfiles)
            With Range("B" & Rows.Count).End(xlUp).offset(1)
                .Hyperlinks.Add ActiveCell, SourceFolderName & "\" & strFiles(lngX), , , strFiles(lngX)
                .offset(, 1).Value = SourceFolder.files(strFiles(lngX)).DateCreated
            End With
    Next

    Columns("A:B").AutoFit

    Set SourceFolder = Nothing
    Set FSO = Nothing

End Sub

使用VBA和FileSystemObject在Excel中组织文件

2 个答案: