Function UserGetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show - 1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
UserGetFolder = sItem
Set fldr = Nothing
End Function
Sub GetFolder()
Range("A:B").ClearContents
Range("A1").Value = "Original FilName"
Range("B1").Value = "Path"
Range("A1").Select
Dim strPath As String
'strPath = "C:\"
strPath = UserGetFolder
Dim OBJ As Object, Folder As Object, File As Object
Set OBJ = CreateObject("Scripting.FileSystemObject")
[COLOR=#ff0000]Set Folder = OBJ.GetFolder(strPath)[/COLOR]
Call ListFiles(Folder)
Dim SubFolder As Object
For Each SubFolder In Folder.SubFolders
Call ListFiles(SubFolder)
Call GetSubFolders(SubFolder)
Next SubFolder
Range("A1").Select
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ListFiles(ByRef Folder As Object)
For Each File In Folder.Files
ActiveCell.Offset(1, 0).Select
ActiveCell = File.Name
ActiveCell.Offset(0, 1) = File.Path
Next File
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub GetSubFolders(ByRef SubFolder As Object)
Dim FolderItem As Object
For Each FolderItem In SubFolder.SubFolders
Call ListFiles(FolderItem)
Call GetSubFolders(FolderItem)
Next FolderItem
End Sub