花更长的时间来获得LastModified Date VBA

时间:2018-04-09 05:12:18

标签: vba excel-vba excel

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

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个文件,需要数小时才能运行。

先谢谢。

1 个答案:

答案 0 :(得分:0)

命令行?以下内容将详细信息写入即时窗口。 C:\Users\User\Desktop\TestFolder是要循环的文件夹,您可以将其提取到变量中。如果有很多文件你不会调试.print但是可以将数组直接写入工作表。

Option Explicit

Public Sub Find_Files()

    Dim fileDetails() As String
    fileDetails = Split(CreateObject("wscript.shell").exec("cmd /c cd C:\Users\User\Desktop\TestFolder && 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 = "\Folder1\Folder2\TestFolder"
    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