Taking Longer time to get LastModified Date VBA - vba

Question

I am using the below code to get the last modified datetime of a file from a shared folder.
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
Could someone suggest how can be improved the performance of the above code.
There are 7k files inside that folder and taking hours to run.
Thanks in Advance.

Answer 1

Command line? The following writes out the details to the immediate window.
C:\Users\User\Desktop\TestFolder is the folder to loop over which you can extract out into a variable. If there are a lot of files you wouldn't debug.print but could write array direct out to sheet.
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
Messy version for network drive:
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