0

我有脚本来扫描文件夹以查找文件名包含特定文本的文件。该脚本有效，但它在没有完成对整个文件夹的扫描后停止（我达到了 16663 次扫描，有限制吗？）。我不知道为什么脚本会停止。任何帮助是极大的赞赏。

我最初使用这篇文章中发布的代码Get list of sub-directories in 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
4

0 回答 0