Excel VBA Список файлов, сгруппированных по папкам - PullRequest
Новая
       30

Excel VBA Список файлов, сгруппированных по папкам

1 голос
/ 31 мая 2019

Следующий макрос отлично справляется с группированием файлов по папкам, однако он очень медленный, когда запускается в каталоге с десятками тысяч файлов (например, «Мои рисунки»).Есть ли способ ускорить его? 

Option Explicit
Sub cmdList()
Dim objShell    As Object
Dim objFolder   As Object
Dim sPath       As String
Dim fOut        As Variant
Dim r           As Integer
Dim listRng     As Range
Dim cell        As Range
Dim i           As Integer
Dim j           As Integer

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Select Folder", 0, 17)
If objFolder Is Nothing Then Exit Sub
Application.ScreenUpdating = False
sPath = objFolder.self.Path
Set objFolder = Nothing: Set objShell = Nothing

r = 6: Range(r & ":" & Rows.Count).Delete
Cells(r - 1, 1) = sPath

fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & sPath & """ /a:-h-s /b /s").StdOut.ReadAll, vbNewLine)

Cells(r, 1).Resize(UBound(fOut), 1) = WorksheetFunction.Transpose(fOut)

Set listRng = Cells(r, 1).CurrentRegion
listRng.Sort Key1:=Cells(r, 1), Order1:=xlAscending, Header:=xlYes

For i = 1 To listRng.Count
    For j = i + 1 To listRng.Count
        If InStr(listRng.Cells(j), listRng.Cells(i)) Then
            With listRng.Cells(j)
                .Rows.Group
                .IndentLevel = .Rows.OutlineLevel - 1
            End With
        Else
            Exit For
        End If
    Next j
Next i
Application.ScreenUpdating = True
End Sub

Результат, которого я хочу добиться, таков:

Уровень 1 ....

Level 1

Уровень 2 ...

Level 2

Уровень 3 ...

Level 3

1 Ответ

1 голос
/ 04 июня 2019

РЕДАКТИРОВАТЬ : ответ обновляется, чтобы изменить группировку на выше и исправить условие, при котором строки с отступом и группировкой были некорректно.

Так что это была интересная проблема для решения. В дополнение к реальному решению у меня есть несколько других советов, которые я обычно включаю в свой код, которые я также буду вызывать. Мое решение - ОЧЕНЬ также быстро. Когда я проанализировал дерево каталогов C: \ Program Files \ (18 017 файлов), он запустился менее чем за 5 секунд.

  1. Объявите ваши переменные как можно ближе к точке, в которой они используются впервые. Это значительно упрощает определение типа и определения переменной, а также помогает функционально сгруппировать код.
  2. Эти логические группы затем могут быть функционально разделены на отдельные функции и подсистемы. Это сделает основную логику вашего кода намного проще для понимания в одном быстром просмотре, вместо того, чтобы потребовать от читателя (вероятно, YOU через несколько месяцев) перечитать большие логические разделы и переварить их по порядку чтобы понять это.

В моем примере кода я начинаю с трех быстрых функций, которые точно сообщают вам, что происходит: 

Dim rootFolder As String
rootFolder = SelectFolder

Dim pathArray As Variant
pathArray = GetAllFiles(rootFolder)

Dim folderGroups As Object
Set folderGroups = BuildFolderDictionary(pathArray)

Первая функция проста и точно соответствует вашему подходу к выбору корневой папки: 

Private Function SelectFolder() As String
    '--- returns the user-selected folder as a string
    Dim objShell As Object
    Dim objFolder As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Select Folder", 0, 17)
    If Not objFolder Is Nothing Then
        SelectFolder = objFolder.self.path
    End If
End Function

Следующая функция (GetAllFiles) также использует ваш подход, но вместо того, чтобы помещать результаты непосредственно в таблицу, она сохраняет результаты в массиве на основе памяти (в нижней части этого ответа я включаю весь модуль в один блок кода для копирования / вставки позже): 

Private Function GetAllFiles(ByVal rootPath As String, _
                             Optional onlyFolders As Boolean = False) As Variant
    '--- returns a sorted array of all filepaths in the given directory path
    Dim dirOptions As String
    If onlyFolders Then
        dirOptions = """ /a:d-h-s /b /s"
    Else
        dirOptions = """ /a:-h-s /b /s"
    End If
    Dim fOut() As String
    fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & _
                                                    rootPath & _
                                                    dirOptions).StdOut.ReadAll, _
                 vbNewLine)
    QuickSort fOut, LBound(fOut), UBound(fOut)

    '--- the pathArray skips the first position from the fOut array
    '    because it's always blank, but add the root folder as the first entry
    Dim pathArray As Variant
    ReDim pathArray(1 To UBound(fOut) + 1, 1 To 1)
    pathArray(1, 1) = rootPath
    Dim i As Long
    For i = 2 To UBound(fOut) + 1
        pathArray(i, 1) = fOut(i - 1)
    Next i
    GetAllFiles = pathArray
End Function

Массивы на основе памяти НАМНОГО, НАМНОГО быстрее, чем работа напрямую с листа с помощью Cells или Ranges.

Следующая функция (BuildFolderDictionary) работает с использованием массива путей и создает список (Dictionary) уникальных папок в иерархии папок. Попутно он также создает «промежуток» строк, который охватывает подпапка. Это будет очень полезно позже. Помните, мы делаем все это в памяти, поэтому это быстро. 

Private Function BuildFolderDictionary(ByRef paths As Variant) As Object
    Dim folders As Object
    Set folders = CreateObject("Scripting.Dictionary")

    '--- scan all paths and create a dictionary of each folder and subfolder
    '    noting which items (rows) map into each dictionary
    Dim i As Long
    For i = LBound(paths) To UBound(paths)
        Dim folder As String
        Dim pos1 As Long
        If Not IsEmpty(paths(i, 1)) Then
            pos1 = InStrRev(paths(i, 1), "\")   'find the last folder separator
            folder = Left$(paths(i, 1), pos1)
            If Not folders.Exists(folder) Then
                '--- new (sub)folder, create a new entry
                folders.Add folder, CStr(i) & ":" & CStr(i)
            Else
                '--- extisting (sub)folder, add to the row range
                Dim rows As String
                rows = folders(folder)
                rows = Left$(rows, InStr(1, rows, ":"))
                rows = rows & CStr(i)
                folders(folder) = rows
            End If
        End If
    Next i

    '--- final fixup: the root folder group should always encompass all
    '    the entries (runs from the second row to the end)...
    '    and we'll also determine the indent level using the first entry
    '    as the baseline (level 1).  stored as "rows,level" e.g. "2:7,1"
    Dim rootSlashes As Long
    rootSlashes = Len(root) - Len(Replace(root, "\", "")) - 1
    folders(root) = "2:" & UBound(paths) & ",1"

    Dim slashes As Long
    folder = folders.Keys
    For i = 1 To UBound(folder)
        slashes = Len(folder(i)) - Len(Replace(folder(i), "\", ""))
        folders(folder(i)) = folders(folder(i)) & "," & _
                                     CStr(slashes - rootSlashes)
    Next i

    For Each folder In folders
        Debug.Print folder & " - " & folders(folder)
    Next folder

    Set BuildFolderDictionary = folders
End Function

Последние две части - скопировать массив памяти (путей к файлам) на лист ... 

    Const START_ROW As Long = 6
    Dim pathRange As Range
    Set pathRange = Sheet1.Range("A" & START_ROW).Resize(UBound(pathArray) + 1, 1)
    pathRange = pathArray

и затем примените отступ и группировку строк. Мы используем словарь созданных нами групп папок, в котором все строки подпапок уже определены для нас ... 

    Const MAX_GROUP_LEVEL As Long = 8
    Dim rowGroup As Variant
    Dim level As Long
    Dim folderData As Variant
    Dim theseRows As String
    For Each rowGroup In folderGroups
        folderData = Split(folderGroups(rowGroup), ",")
        theseRows = folderData(0)
        level = folderData(1)
        With pathRange.rows(theseRows)
            .IndentLevel = level
            If level < MAX_GROUP_LEVEL Then
                .Group
            End If
        End With
    Next rowGroup

(Я столкнулся с проблемой во время тестирования, когда программа допустила ошибку с уровнем группы глубже, чем 8. Поэтому я установил ограничение в логике, чтобы предотвратить ошибку.)

Итак, теперь весь модуль в одном блоке: 

Option Explicit

Public Sub ShowFilePaths()
    Dim rootFolder As String
    rootFolder = SelectFolder
    If rootFolder = vbNullString Then Exit Sub

    '--- quick fixup if needed
    rootFolder = rootFolder & IIf(Right$(rootFolder, 1) = "\", vbNullString, "\")

    Dim pathArray As Variant
    pathArray = GetAllFiles(rootFolder)

    Dim folderGroups As Object
    Set folderGroups = BuildFolderDictionary(rootFolder, pathArray)

    '--- when debugging, this block just clears the worksheet to make it
    '    easier to rerun and test the code
    On Error Resume Next
    With Sheet1
        .UsedRange.ClearOutline
        .UsedRange.Clear
        .Outline.SummaryRow = xlAbove
    End With
    Err.Clear
    On Error GoTo 0

    '--- copy the array to the worksheet
    Const START_ROW As Long = 6
    Dim pathRange As Range
    Set pathRange = Sheet1.Range("A" & START_ROW).Resize(UBound(pathArray), 1)
    pathRange = pathArray

    '------ now apply the indention levels to each line on the sheet
    '       and group the same rows
    Const MAX_GROUP_LEVEL As Long = 8
    Dim rowGroup As Variant
    Dim level As Long
    Dim folderData As Variant
    Dim theseRows As String
    For Each rowGroup In folderGroups
        folderData = Split(folderGroups(rowGroup), ",")
        theseRows = folderData(0)
        level = folderData(1)
        With pathRange.rows(theseRows)
            .IndentLevel = level
            If level < MAX_GROUP_LEVEL Then
                .Group
            End If
        End With
    Next rowGroup
End Sub

Private Function SelectFolder() As String
    '--- returns the user-selected folder as a string
    Dim objShell As Object
    Dim objFolder As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Select Folder", 0, 17)
    If Not objFolder Is Nothing Then
        SelectFolder = objFolder.self.Path
    End If
End Function

Private Function GetAllFiles(ByVal rootPath As String, _
                             Optional onlyFolders As Boolean = False) As Variant
    '--- returns a sorted array of all filepaths in the given directory path
    Dim dirOptions As String
    If onlyFolders Then
        dirOptions = """ /a:d-h-s /b /s"
    Else
        dirOptions = """ /a:-h-s /b /s"
    End If
    Dim fOut() As String
    fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & _
                                                    rootPath & _
                                                    dirOptions).StdOut.ReadAll, _
                 vbNewLine)
    QuickSort fOut, LBound(fOut), UBound(fOut)

    '--- the pathArray skips the first position from the fOut array
    '    because it's always blank, but add the root folder as the first entry
    Dim pathArray As Variant
    ReDim pathArray(1 To UBound(fOut) + 1, 1 To 1)
    pathArray(1, 1) = rootPath
    Dim i As Long
    For i = 2 To UBound(fOut) + 1
        pathArray(i, 1) = fOut(i - 1)
    Next i
    GetAllFiles = pathArray
End Function

Private Function BuildFolderDictionary(ByVal root As String, _
                                       ByRef paths As Variant) As Object
    Dim folders As Object
    Set folders = CreateObject("Scripting.Dictionary")

    '--- scan all paths and create a dictionary of each folder and subfolder
    '    noting which items (rows) map into each dictionary
    Dim folder As Variant
    Dim i As Long
    For i = LBound(paths) To UBound(paths)
        Dim pos1 As Long
        If Not IsEmpty(paths(i, 1)) Then
            pos1 = InStrRev(paths(i, 1), "\")   'find the last folder separator
            folder = Left$(paths(i, 1), pos1)
            If Not folders.Exists(folder) Then
                '--- new (sub)folder, create a new entry
                folders.Add folder, CStr(i) & ":" & CStr(i)
            Else
                '--- extisting (sub)folder, add to the row range
                Dim rows As String
                rows = folders(folder)
                rows = Left$(rows, InStr(1, rows, ":"))
                rows = rows & CStr(i)
                folders(folder) = rows
            End If
        End If
    Next i

    '--- final fixup: the root folder group should always encompass all
    '    the entries (runs from the second row to the end)...
    '    and we'll also determine the indent level using the first entry
    '    as the baseline (level 1).  stored as "rows,level" e.g. "2:7,1"
    Dim rootSlashes As Long
    rootSlashes = Len(root) - Len(Replace(root, "\", "")) - 1
    folders(root) = "2:" & UBound(paths) & ",1"

    Dim slashes As Long
    folder = folders.Keys
    For i = 1 To UBound(folder)
        slashes = Len(folder(i)) - Len(Replace(folder(i), "\", ""))
        folders(folder(i)) = folders(folder(i)) & "," & _
                                     CStr(slashes - rootSlashes)
    Next i

    For Each folder In folders
        Debug.Print folder & " - " & folders(folder)
    Next folder

    Set BuildFolderDictionary = folders
End Function

Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
    '--- from https://stackoverflow.com/a/152333/4717755
    Dim P1 As Long, P2 As Long, Ref As String, TEMP As String

    P1 = LB
    P2 = UB
    Ref = Field((P1 + P2) / 2)

    Do
        Do While (Field(P1) < Ref)
            P1 = P1 + 1
        Loop

        Do While (Field(P2) > Ref)
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Field(P1)
            Field(P1) = Field(P2)
            Field(P2) = TEMP

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(Field, LB, P2)
    If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...