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 = FalseDim fldpathDim fso As Object, j As Long, folder1 As ObjectWith Application.FileDialog(msoFileDialogFolderPicker).Title = "Choose the folder".ShowEnd WithOn Error Resume Nextfldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"If fldpath = False ThenMsgBox "Folder Not Selected"Exit SubEnd IfWorkbooks.AddCells(1, 1).Value = fldpathCells(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 folder1Set fso = NothingRange("a1").Font.Size = 9ActiveWindow.DisplayGridlines = FalseRange("a3:e" & Range("a2").End(xlDown).Row).Font.Size = 9Range("a2:e2").Interior.Color = vbCyanColumns("c:h").AutoFitApplication.ScreenUpdating = True
End SubSub get_sub_folder (ByRef prntfld As Object)
Dim SubFolder As Object, subfld As Object, j As LongFor Each SubFolder In prntfld.SubFoldersj = Range("A1").End(xlDown).Row + 1Cells(j, 1).Value = SubFolder.PathCells(j, 2).Value = Left(SubFolder.Path, InStrRev(SubFolder.Path, "\"))Cells(j, 3).Value = SubFolder.NameCells(j, 4).Value = SubFolder.DateCreatedCells(j, 5).Value = SubFolder.DateLastModifiedNext SubFolderFor Each subfld In prntfld.SubFoldersget_sub_folder subfldNext subfld
End Sub
Reference:
Tags: VBA, Excel, Tips, folder, pasta, diretório, subdiretório, Get, sub folder, names
Nenhum comentário:
Postar um comentário