快速找到子文件夹

Question

所以我有一段代码可以扫描源文件夹中包含的子文件夹。我知道每个子文件夹名称的第一部分（或者至少，这是我滚动浏览的已知变量），其余部分是确定哪个设计是最新的“问题编号”。在这些子文件夹中是我然后复制到其他目录中的文件以供进一步使用。

问题是我使用 For 循环扫描每个子文件夹，直到找到文件夹名称的相关开始部分，然后记录下半部分以进行比较。

这需要相当长的时间（大约有 21,000 个子文件夹，而且列表每天都在增长），我希望找到一种更快的方法来达到同样的目的。

有这种事，还是我咬紧牙关忍着！？

如果有帮助，文件夹的格式总是相同的，例如 DP0123456_00_01_003，目前我正在搜索 DP0123456 部分并将其余部分记录为比较器。以下是我目前使用的...

Sub Build_Issue_list()
    Dim objFSO As FileSystemObject, objFolder As Folder, objSub As Folder
    Dim MajArr(99) As String, MinArr(99) As String, DoArr(999) As String
    Dim FullArr(99) As String
    Dim IssCnt As Integer

    Dim StrSourceFolder As String

    Dim TopIssue As String
    Dim TmpStr As String
    Dim DpNo As String

    Dim dpCount As Integer, DpScroll As Integer

    Dim StartRow As Integer, StartCol As Integer

    Dim FoundIt As Boolean
    Dim I As Integer
    IssErr = False

    'default to start looking for list is "a5"
    StartRow = 5
    StartCol = 1
    dpCount = GetTableRows(StartRow, StartCol)
    'MsgBox DpCount

    For DpScroll = StartRow To dpCount
        DpNo = Cells(DpScroll, StartCol)

        'THIs BLOCK TAKES A DPNO AND FINDS THE HIGHEST ISSUE OF IT FOUND.
        '''''''''''''''''''''''''''''''''''''''''''''''''
        Set objFSO = New FileSystemObject 'creates a new File System Object reference
        Set objFolder = objFSO.getfolder(StrSourceFolder) 'get the folder
        IssCnt = 0
        For Each objSub In objFolder.Subfolders 'for every sub-folder in the folder...
            'see if the DPno matches
            If objSub.Name Like DpNo & "*" Then
                'note that one instance is found
                FoundIt = True
                'record the rest as 3 seperate parts
                TmpStr = Replace(objSub.Name, DpNo & "_", "")
                MajArr(IssCnt) = Left(TmpStr, 2)
                MinArr(IssCnt) = Mid(TmpStr, 4, 2)
                DoArr(IssCnt) = Right(TmpStr, 3)
                'combine these for later
                FullArr(IssCnt) = MajArr(IssCnt) & MinArr(IssCnt) & DoArr(IssCnt)

                'MsgBox DPno & vbCrLf & TmpStr & vbCrLf & MajArr(IssCnt) & vbCrLf & MinArr(IssCnt) & vbCrLf & DoArr(IssCnt) & vbCrLf & FullArr(IssCnt)
                IssCnt = IssCnt + 1
            ElseIf FoundIt = True Then
                'assuming folders are scanned in order? if a non-matching one is subsequently found then stop looking
                FoundIt = False
                Exit For
            End If
        Next
        'temporarily stick screenupdating on to give user some feedback on progress!
        Application.ScreenUpdating = True
        'IOMaxValOfIntArray is a function that gets the index of the highest integer in array.
        'This coincides with the index used across other isses, so when "topissue" is concatenated it will match the highest issue found.
        IssCnt = IOMaxValOfIntArray(FullArr)
        TopIssue = "_" & MajArr(IssCnt) & "_" & MinArr(IssCnt) & "_" & DoArr(IssCnt)
        'if one was never found then the array will be empty.
        If TopIssue = "___" Then
            TopIssue = "Not found"
            Cells(DpScroll, StartCol + 4) = "Not Found"
            'this prints the DPno to an error message displayed at the end.
            IssErr = True
            IssErrMsg = IssErrMsg & vbCrLf & DpNo
        End If
        '''Print the full issue number, and time found.
        Cells(DpScroll, StartCol + 4) = Format(Timer() / 86400, "HH:MM:SS")
        'MsgBox TopIssue
        Cells(DpScroll, StartCol + 2) = TopIssue
        ' save in case of a rage quit. in this way those that have been retrieved are not reset.
        ActiveWorkbook.Save
        Application.ScreenUpdating = False
        ''''''''''''''''''''''''''''''''''''
        'reset array
        For I = 0 To IssCnt
            MajArr(I) = ""
            MinArr(I) = ""
            DoArr(I) = ""
            FullArr(I) = ""
        Next
    Next

    If IssErr Then MsgBox IssErrMsg

End Sub

Answer 1

稍后我会尝试提供更多详细信息...但是您可以使用 Dir 命令返回与模式匹配的文件系统对象... 所以首先你会运行 Dir("DP0123456*") 来获得你的第一场比赛。然后只需 Dir() 获取后续的，直到它返回一个空白（意味着不再匹配）

Answer 2

考虑Shell32 的用法。将此代码放在 Sub 的开头：

' add reference to Microsoft Shell Controls and Automation (Shell32)
Const SHCONTF_FOLDERS = &H20
Const SHCONTF_INCLUDEHIDDEN = &H80
Dim Shell As Shell32.Shell
Dim FolderItems As Shell32.FolderItems
Dim FolderItem As Shell32.FolderItem
Set Shell = New Shell32.Shell

这是填充数组的部分代码：

    '''''''''''''''''''''''''''''''''''''''''''''''''
    Set FolderItems = Shell.NameSpace(StrSourceFolder).Items
    FolderItems.Filter SHCONTF_FOLDERS + SHCONTF_INCLUDEHIDDEN, DpNo & "_*"
    IssCnt = 0
    For Each FolderItem In FolderItems
        TmpStr = Replace(FolderItem.Name, DpNo & "_", "")
        MajArr(IssCnt) = Left(TmpStr, 2)
        MinArr(IssCnt) = Mid(TmpStr, 4, 2)
        DoArr(IssCnt) = Right(TmpStr, 3)
        'combine these for later
        FullArr(IssCnt) = MajArr(IssCnt) & MinArr(IssCnt) & DoArr(IssCnt)
        'MsgBox DPno & vbCrLf & TmpStr & vbCrLf & MajArr(IssCnt) & vbCrLf & MinArr(IssCnt) & vbCrLf & DoArr(IssCnt) & vbCrLf & FullArr(IssCnt)
        IssCnt = IssCnt + 1
    Next