Вот решение с использованием массивов.
Option Explicit
Const StartDate As Date = #1/1/2019# ' inclusive
Const EndDate As Date = #12/31/2019# ' inclusive
Private Sub Test()
Dim Arr() As String
Dim i As Long
Arr = ListOfFiles
For i = 1 To UBound(Arr)
Debug.Print i, Arr(i)
Next i
With ActiveSheet
.Cells(1, "B").Resize(UBound(Arr)).Value = Application.Transpose(Arr)
End With
End Sub
Function ListOfFiles() As String()
' code by:
' https://stackoverflow.com/questions/14245712/cycle-through-sub-folders-and-files-in-a-user-specified-root-directory
' modified for this project:
' https://stackoverflow.com/questions/60536325/lower-run-time-currently-3-hours-vba-loop-through-specific-subfolders?noredirect=1#comment107097419_60536325
' by Variatus @STO 05 Mar 2020
' set the start directory as required
Const StartDir As String = "F:\AWK PC\Drive E (Archive)\PVT Archive\"
Dim Fun() As String ' function return array
Dim ArrIdx As Long
Dim RootDir As String
Dim Fso As FileSystemObject
Dim FirstFld As Folder
Dim Fld As Folder
Dim Fltr As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = StartDir
.AllowMultiSelect = False
If Not .Show Then
MsgBox "No folder selected!" & vbCr & _
"Exiting script.", vbInformation, "Cancel action"
Exit Function
End If
RootDir = .SelectedItems(1)
End With
ReDim Fun(1 To 10000) ' allow a number of files larger than expected
' it's important to start at 1
ArrIdx = 0
Set Fso = New FileSystemObject
Set FirstFld = Fso.GetFolder(RootDir)
Fltr = ".cvs"
ListFiles FirstFld, Fltr, Fun, ArrIdx
For Each Fld In FirstFld.SubFolders
ListFiles Fld, Fltr, Fun, ArrIdx
ListFolders Fld, Fltr, Fun, ArrIdx
Next Fld
ReDim Preserve Fun(1 To ArrIdx)
ListOfFiles = Fun
Application.StatusBar = "Done"
End Function
Sub ListFolders(FirstFld As Folder, _
Fltr As String, _
Fun() As String, _
Idx As Long)
Dim Fld As Folder
For Each Fld In FirstFld.SubFolders
ListFiles Fld, Fltr, Fun, Idx
ListFolders Fld, Fltr, Fun, Idx
Next Fld
End Sub
Sub ListFiles(Fld As Folder, _
Fltr As String, _
Fun() As String, _
Idx As Long)
Dim ModDate As Date
Dim Fil As File
For Each Fil In Fld.Files
' exclude temporary files marked with ~ by the system
With Fil
If (Right(.Name, 4) = Fltr) And (Asc(.Name) <> 126) Then
ModDate = Fil.DateLastModified
' skip files not within date range
If (ModDate >= StartDate) And (ModDate <= EndDate) Then
Idx = Idx + 1
Fun(Idx) = Fld.Path & "\" & .Name
If Idx Mod 50 = 1 Then Application.StatusBar = Idx & " files copied."
End If
End If
End With
Next Fil
End Sub
Можно установить 3 константы, StartDate и EndDate в верхней части таблицы кодов и StartDir в процедуре ListOfFiles. Если вы не установите последний, Folderpicker запустится в каталоге, который вы в последний раз использовали. Я также рекомендую изменить ссылку на ActiveSheet в Sub Test, чтобы она указывала на чистый лист, который вы вставляете в свою книгу для целей тестирования.
Когда все настроено, запустите процедуру Test , Он вызовет функцию ListOfFiles, которая проходит через все указанные папки и подпапки и возвращает массив квалифицированных имен файлов. В этом списке процедура Test сначала печатается в «Немедленное окно», а затем в столбец B пустой рабочей таблицы, упомянутой выше. Это даст вам представление о том, что у вас есть и что с этим можно сделать. Ваше тестирование должно включать проверку того, включены ли первый и последний соответствующие файлы в массив и списки. Это очень популярная ошибка в программировании, чтобы обрезать их, и мое тестирование было ограничено кодом без сбоев.
Я протестировал около 300 файлов, извлек 71 из них, и это заняло около 3 секунд. По этой мере ваш список должен быть готов менее чем за 2 минуты. В строке состояния есть индикатор прогресса.
Я не понимаю, что вы хотите делать с файлами, но если вы хотите извлечь из них данные, обратите внимание, что вам не обязательно открывать их для этого. цель. Мне кажется, что лучший способ извлечь данные из закрытого файла CSV не входит в сферу вашего нынешнего вопроса.