Загрузка списка подпапок (2 уровней) в Excel

Скриншот таблицы Excel со списком папок и подпапок

Макрос предназначен для загрузки в Excel списка подпапок заданной папки

Для каждой из найденных папок производится поиск всех подпапок, и для каждой подпапки из списка выводится необходимая информация (в частности, количество файлов и подпапок, а также размер папки в байтах)

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

Также обратите внимание, что в столбце «размер папки» хоть число и выводится с единицей измерения (слово «байтов»), тем не менее, в ячейках хранятся числовые значения, что позволяет корректно выполнять сортировку, и использовать значения этих ячеек в формулах

Смотрите также макрос загрузки списка файлов из заданной папки,
и макрос загрузки списка подпапок выбранной папки

Код макроса:

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

Вложения:
FoldersList.xls58.5 КБ

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Спасибо. Отлично работает

Спасибо, как можно добавить чтобы показывал дата создании и изменении папок?

Большое спасибо за макрос! Очень помог.

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

Делать пример не буду - т.к. не факт, что результат вам нужен будет именно в таком виде, а переделывать макрос по 10 раз уж очень не хочется.

Если хотите готовое решение - можете оформить заказ

Очень ценный файл. Было бы вообще отлично если можно было бы выбирать глубину подпасок. Если Вам не трудно сделать это.Заранее спасибо.

Если это не очень трудоемко и можно добавить глубину поиска, то буду очень признателен (и думаю не только я) за модификацию программы.

Ничуть не сомневаюсь, что возможность задать глубину поиска в этом макросе в сотни раз повысит его цену.
Вот только после этой доработки макрос станет настолько ценным, что не факт, что вам хватит средств на его покупку :)

Я усложняю макросы, только либо когда меня вежливо об этом просят, либо когда за это платят. А "на слабо" я не ведусь...

Спасибо! а параметризовать глубину вложенности слабо? :)
Ценность такого макроса будет намного выше.

Вы просто волшебник!!!!!!! Просто есть всё что доктор прописал!!!!я на 10-ом небе от счастья, за полминуты сделалось за счёт макроса у меня то, на что бы я потратила вручную несколько месяцев. Полгода собиралась, что только не перепробовала и через командную строку и в ручнуоку добывала, но коверкает русские буквы и вручную уже пыталась, на крайний случай уже собиралась скриншотами орудовать, катологизаторы вообще висли от такого количества папок и файлов (кстати оказалось, что папочек 3545штучек) :) ЖИЗНЬ ТЕПЕРЬ ПРЕКРАСНА!
Спасибо огромное!!!!!
С наступающим Новым годом Вас!!!!!

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
          ____   __   __ __   __  ____    _   _ 
__ _ | _ \ \ \ / / \ \ / / |___ \ | | | |
/ _` | | | | | \ V / \ V / __) | | | | |
| (_| | | |_| | | | | | / __/ | |_| |
\__, | |____/ |_| |_| |_____| \___/
|___/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.