Макрос - перечень папок

 '---------------------------------------------------------------------------------------

' Module        : Module1

' Автор     : EducatedFool  (Игорь)                    Дата: 24.12.2011

' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.

' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru

' Реквизиты для оплаты работы: http://ExcelVBA.ru/payments

'---------------------------------------------------------------------------------------

Option Compare Text

Sub ЗагрузкаСпискаПодпапок()

    On Error Resume Next: Application.ScreenUpdating = False

    FolderPath$ = Trim([c1])    ' путь к папке - из ячейки С1

    If Right(FolderPath$, 1) <> "\" Then FolderPath$ = FolderPath$ & "\"

    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject

    Set curfold = FSO.GetFolder(FolderPath$)

    ' выводим информацию о главной папке в ячейку E1

    [e1] = "Файлов: " & curfold.Files.Count & "; папок: " & curfold.SubFolders.Count

    Dim ra As Range

    For Each folder In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath

        f1 = folder.Name    ' название первой подпапки

        ' выводим информацию в строку состояния

        Application.StatusBar = "Обрабатывается папка " & f1: DoEvents

        

        For Each subfolder In folder.SubFolders    ' перебираем все подпапки в папке curfold

            n = n + 1: DoEvents: f2 = subfolder.Name    ' название вложенной подпапки

            info = "Файлов: " & subfolder.Files.Count & "; папок: " & subfolder.SubFolders.Count

            Size = subfolder.Size    ' размер папки

            

            ' диапазон для вставки информации об очередной папке

            Set ra = Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 5)

            ra.Value = Array(n, f1, f2, info, Size) ' заполняем ячейки данными

            

            ' добавляем гиперссылки в 2 ячейки

            ra.Hyperlinks.Add ra.Cells(2), folder.Path, "", _

                              "Открыть папку " & f1 & vbNewLine & " в директории " & FolderPath$

            ra.Hyperlinks.Add ra.Cells(3), subfolder.Path, "", _

                              "Открыть подпапку " & f2 & vbNewLine & " в папке " & f1

        Next subfolder

    Next folder

    Set FSO = Nothing

    Application.StatusBar = False ' очистка строки состояния Excel

End Sub

Sub Очистка()

    On Error Resume Next

    Dim ra As Range: Set ra = Range([A3], Range("A" & Rows.Count).End(IIf(Len(Range("A" & Rows.Count)), xlDown, xlUp))).Resize(, 5)

    If ra.Row > 2 Then ra.ClearContents

End Sub