VBA Excel рекурсивный поиск папок останавливается - PullRequest
Новая
       43

VBA Excel рекурсивный поиск папок останавливается

0 голосов
/ 22 октября 2018

У меня есть скрипт для сканирования папки на наличие файлов с именем, содержащим определенный текст.Сценарий работает, но через некоторое время останавливается без завершения сканирования всей папки (я достиг 16663 проверок, есть ли предел?).Я не могу понять, почему сценарий останавливается.Любая помощь очень ценится.

Я изначально использовал код, опубликованный в этом сообщении Получить список подкаталогов в VBA

Обновление: сканируемый диск является сетевым диском,Теперь я предполагаю, что из-за скачка соединения скрипт останавливается.В настоящее время я пробую разные подходы, чтобы обойти это ... 

Sub LoopThroughFilePaths()

    Application.StatusBar = True
    Application.ScreenUpdating = False

    Counter = 1

    Dim strPath As String
    strPath = "V:\50"                            ' folder to scan

    Dim myArr
    myArr = GetSubFolders(strPath)

    Application.StatusBar = False
    Application.ScreenUpdating = True

End Sub

Используемая функция GetSubFolders

Function GetSubFolders(RootPath As String)

    Application.ScreenUpdating = False

    Dim fso As Object
    Dim fld As Object
    Dim sf As Object
    Dim myArr
    Dim output As String
    Dim StrFileOut As String
    VAR_01_output = "D:\output"                  'Location to copy found files to

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(RootPath)

    Dim StrFile As String
    StrFile = Dir(fld + "\*labsuite*")           'wild card search for files

    Do While Len(StrFile) > 0
        StrFileOut = Format(Now(), "hh-mm-ss") & "_" & StrFile ' rename files
        FileCopy fld + "\" + StrFile, VAR_01_output + "\" + StrFileOut 'copy found files to output folder
        StrFile = Dir
    Loop

    For Each sf In fld.SubFolders
        ReDim Preserve Arr(Counter)
        Arr(Counter) = sf.Path
        Counter = Counter + 1

        On Error Resume Next
        myArr = GetSubFolders(sf.Path)
        On Error Resume Next

        'ActiveWorkbook.Sheets(1).Cells(1, 1).Value = Counter
        Application.StatusBar = sf.Path

        DoEvents
    Next

    GetSubFolders = Arr

    Set sf = Nothing
    Set fld = Nothing
    Set fso = Nothing

End Function
...