'---------------------------------------------------------------------------------------
' 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
