需要更长的时间才能获得上次修改日期VBA

Question

我使用以下代码从共享文件夹中获取文件的上次修改日期时间。

Public Sub CountTextFilesInFolder()
FolderPath = "\SVTickets"
Count = 0
If Right(FolderPath, 1) = "" Then
    SourcePath = FolderPath
    SourcPath = SourcePath & "*.txt"
ElseIf Right(FolderPath, 1) <> "" Then
    SourcePath = FolderPath
    SourcPath = SourcePath & "*.txt"
End If
FileName = Dir(SourcPath)
Do While FileName <> ""
    DateTim = FileDateTime(SourcePath & FileName)
    If Format(DateTim, "YYYYMMDD") = Format(Date, "YYYYMMDD") Then
        Count = Count + 1
    End If
    FileName = Dir()
Loop
End Sub

有人可以建议如何提高上述代码的性能。该文件夹中有 7k 个文件，需要数小时才能运行。

提前谢谢。

Answer 1

命令行？下面将详细信息写出到即时窗口。 C:UsersUserDesktopTestFolder是要循环的文件夹，您可以在其上提取到变量中。如果有很多文件，你不会调试.print，但可以直接将数组写到工作表。

Option Explicit
Public Sub Find_Files()
    Dim fileDetails() As String
    fileDetails = Split(CreateObject("wscript.shell").exec("cmd /c cd C:UsersUserDesktopTestFolder && for /f %a in ('dir /b *.txt') do @echo %a %~ta").stdout.readall, vbCrLf)
    Dim i As Long
    For i = LBound(fileDetails) To UBound(fileDetails)
        If Not IsEmpty(fileDetails(i)) Then Debug.Print fileDetails(i)
    Next i
End Sub

网络驱动器的凌乱版本：

Option Explicit
Public Sub Find_Files()
    Dim folderpath As String
    Dim drive As String
    folderpath = "Folder1Folder2TestFolder"
    drive = "R:"
    Dim fileDetails() As String
    fileDetails = Split(CreateObject("wscript.shell").exec("cmd /c cd /D " & drive & " && cd " & folderpath & " && for /f %a in ('dir /b *.txt') do @echo %a %~ta").stdout.readall, vbCrLf)
    Dim i As Long
    For i = LBound(fileDetails) To UBound(fileDetails)
        If Not IsEmpty(fileDetails(i)) Then Debug.Print fileDetails(i)
    Next i
End Sub