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

快速找到一个子文件夹

2 个答案: