VBA - добавить фильтр имен папок в рекурсивный поиск DIR - PullRequest
Новая
       11

VBA - добавить фильтр имен папок в рекурсивный поиск DIR

0 голосов
/ 26 сентября 2019

Мне нужна помощь по внедрению фильтра для ускорения поиска файлов с помощью функции DIR в VBA.

Контекст: У меня есть папка с контрактами.Некоторые контракты находятся непосредственно на нем, некоторые находятся в отдельных подпапках категории.Так это выглядит так: Folder architecture

В каждой папке контракта мне нужно найти файл, имя которого содержит «RENS_RES», расположенный в «2000 * \ 2300 * \»,И мне нужно получить путь к этому файлу

Ситуация: Функция работает.Но это медленно, потому что все на сервере, и есть много папок / подпапок / файлов, которые нужно просмотреть, и он проверяет их все.Это может занять до 15 минут.

Так что я хочу сделать это быстрее.

Сейчас у меня есть код, который выглядит следующим образом: 

Dim fso 'As New FileSystemObject
Dim fld 'As Folder
Public tampon(120) As Variant 'Where I stock my selected files path
sFol = "C:\something\" The path to my main folder, that contains everything, created as String
sFile = "*RENS_RES*.xlsx" 'The criteria to determine the files to select, created as String
Function FindFile(ByVal sFol As String, sFile As String) As String 'Arguments initially from somewhere else specified
'initially called somewhere else

 Dim tFld, tFil as String 'The currently selected folder and file
 Dim FileName As String  'FileName the name of the selected file

 Set fso = CreateObject("Scripting.FileSystemObject")
 Set fld = fso.GetFolder(sFol)
 FileName = Dir(fso.BuildPath(fld.path, sFile), vbNormal Or _
              vbHidden Or vbSystem Or vbReadOnly) 'I search the first file respecting the criteria sFile
 While Len(FileName) <> 0 'I keep going until all files int he folder are tested
  FindFile = FindFile + FileLen(fso.BuildPath(fld.path, _
  FileName))
  tampon(i) = fso.BuildPath(fld.path, FileName) 'We save the value
  i = i + 1
  FileName = Dir()  ' Get next file
  DoEvents
 Wend

 If fld.SubFolders.Count > 0 Then 'If the current folder has subfolders
  For Each tFld In fld.SubFolders 'We consider each subfolder
    If Not (tFld.Name Like "#000*") Or tFld.Name Like "2000*" Or tFld.Name Like "2300*" Then ' We exclude all the subfolders that start with 4 numbers (format x000) and are not 2000 or 2300 from the search
        DoEvents
        FindFile = FindFile + FindFile(tFld.path, sFile) 'We call again the function to test all files in that subfolder
    End If
  Next
 End If
 Exit Function
Catch:  FileName = ""
   Resume Next
End Function

Iпопытался установить фильтр на выбор подпапки:

If Not (tFld.Name Like "#000*") Or tFld.Name Like "2000*" Or tFld.Name Like "2300*" Then

Он имеет инвертированную логику, потому что имитирует выход для "в каждом цикле".

Теоретически не следует вводить «если», если имя начинается с 4 цифр (число, за которым следуют три нуля, а не «2000 *» или «2300 *» (две папки, в которые мы хотим войти). У меня есть этопотому что в категории или имени контракта нет логики, которую я мог бы использовать в фильтре.

Но фильтр не работает: он продолжает проходить через каждую папку, и я не понимаю почему.прошу помощи.

Или есть ли другой способ сделать этот поиск более быстрым?

Заранее спасибо за помощь, надеюсь, я отформатировал код прилично

1 Ответ

0 голосов
/ 26 сентября 2019

Если вы обнаружите, что этот нерекурсивный подход для поиска совпадений проще рассуждать о / изменить: 

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection
    Dim colSub As New Collection

    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder

    Do While colSub.Count > 0

        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1

        For Each f In fldr.Files
            'check filename pattern
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f

        If subFolders Then
            For Each subFldr In fldr.subFolders
                'check subfolder criteria
                'another attempt at your logic...
                If subFldr.Name Like "2000*" or Not subFldr.Name Like "#000*" Then
                    colSub.Add subFldr.Path
                End If
            Next subFldr
        End If

    Loop

    Set GetMatches = colFiles

End Function

Пример использования: 

Dim colFiles as Collection
Set colFiles = GetMatches("C:\something\", ""*RENS_RES*.xlsx"")
...