VBA Excel - Obtendo todos os nomes das subpastas de um diretório - Get Names of all the folders stored in a folder/directory Including Sub folder

Termo de Responsabilidade

Ao efetuar pesquisa de relatório gravados em diversas distintas planilhas, é interessante que saibamos pesquisar o local onde ela esteja. Com este código podemos indicar a apartir de onde a busca inicia.

Sub folder_names_including_subfolder()

Application.ScreenUpdating = False

Dim fldpath

Dim fso As Object, j As Long, folder1 As Object

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Choose the folder"

.Show

End With

On Error Resume Next

fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

If fldpath = False Then

MsgBox "Folder Not Selected"

Exit Sub

End If

Workbooks.Add

Cells(1, 1).Value = fldpath

Cells(2, 1).Value = "Path"

Cells(2, 2).Value = "Dir"

Cells(2, 3).Value = "Name"

Cells(2, 4).Value = "Date Created"

Cells(2, 5).Value = "Date Last Modified"

Set fso = CreateObject("Scripting.FileSystemObject")

Set folder1 = fso.getfolder(fldpath)

get_sub_folder folder1

Set fso = Nothing

Range("a1").Font.Size = 9

ActiveWindow.DisplayGridlines = False

Range("a3:e" & Range("a2").End(xlDown).Row).Font.Size = 9

Range("a2:e2").Interior.Color = vbCyan

Columns("c:h").AutoFit

Application.ScreenUpdating = True

End Sub

Sub get_sub_folder (ByRef prntfld As Object)

Dim SubFolder As Object, subfld As Object, j As Long

For Each SubFolder In prntfld.SubFolders

j = Range("A1").End(xlDown).Row + 1

Cells(j, 1).Value = SubFolder.Path

Cells(j, 2).Value = Left(SubFolder.Path, InStrRev(SubFolder.Path, "\"))

Cells(j, 3).Value = SubFolder.Name

Cells(j, 4).Value = SubFolder.DateCreated

Cells(j, 5).Value = SubFolder.DateLastModified

Next SubFolder

For Each subfld In prntfld.SubFolders

get_sub_folder subfld

Next subfld

End Sub

Reference: 

Tags: VBA, Excel, Tips, folder, pasta, diretório, subdiretório, Get, sub folder, names