Get the List of multiple Folder in Excel

[harky]

possible to Import List (path) of Folder Names from multiple Folder in Excel

Sub ListFolders()
 
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, F As Boolean
    Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
    Dim MySheet As Worksheet
     
    On Error Resume Next
     
    '************************
    'Select folder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        MyPath = objFolder.self.Path & "\"
    Else
        Exit Sub
[COLOR=#ff0000]        MyPath = "C:\Program Files\1" 
[/COLOR][COLOR=#FF0000]C:\Program Files\2[/COLOR][COLOR=#ff0000]
[/COLOR][COLOR=#FF0000]C:\Program Files\3[/COLOR][COLOR=#ff0000]
[/COLOR][COLOR=#FF0000]C:\Program Files\4[/COLOR][COLOR=#ff0000]


[/COLOR]
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
     
    '************************
    'List all folders
     
    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        Key = AllFolders.keys
        MyFolderName = Dir(Key(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (Key(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop
     
    Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub

 

[harky]

or this??

Sub CallSub()
  
' Run this sub
  ListFiles "[COLOR=#FF0000]C:\Program Files\1[/COLOR]" 'Change this line
[COLOR=#FF0000]C:\Program Files\2[/COLOR][COLOR=#ff0000]
[/COLOR][COLOR=#FF0000]C:\Program Files\3[/COLOR][COLOR=#ff0000]
[/COLOR][COLOR=#FF0000]C:\Program Files\4[/COLOR]


End Sub


Sub ListFiles(sFold As String)


'  References MS Scripting
'  Runtime object library


  Dim oFSys As FileSystemObject
  Dim oFile As File
  Dim oFold As Folder
  Dim lNRow As Long


  Set oFSys = New FileSystemObject
  
  If oFSys.FolderExists(sFold) Then
    
    On Error Resume Next
    For Each oFile In oFSys.GetFolder(sFold).Files
      lNRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
      Cells(lNRow, 1).Value = oFile.Path
    Next oFile
    On Error GoTo 0
    
    On Error Resume Next
    For Each oFold In oFSys.GetFolder(sFold).SubFolders
      ListFiles oFold.Path
    Next oFold
    On Error GoTo 0
  
  End If
  
End Sub

 

[harky]

I want something like this code

It display Folder Name & Path

But possible to get name from multiple Folder rather than 1 by 1 open.

C:\Program Files\2
D:\ACB\

Dim fso As Object
Dim nextRow As Long
Dim indent As Long
Dim newSheet As Worksheet
Public Sub ShowFolderDetails()


Set fso = CreateObject("Scripting.FileSystemObject")
Set newSheet = Sheets.Add(after:=Sheets(Sheets.Count))
newSheet.Range("A1").Value = "Name"
newSheet.Range("B1").Value = "Path"
newSheet.Range("1:1").Font.Bold = True


nextRow = 2
indent = 1


With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Environ("USERPROFILE")
    .Show
    RecurseFolder .SelectedItems(1)
End With


newSheet.Columns("A:D").EntireColumn.AutoFit


End Sub
Private Sub RecurseFolder(folderPath As String)


Dim folderCount As Long
Dim fileCount As Long
Dim subFolder As Object
Dim thisFolder As Object


Set thisFolder = fso.GetFolder(folderPath)


folderCount = thisFolder.SubFolders.Count
fileCount = thisFolder.Files.Count
newSheet.Cells(nextRow, 1).Value = thisFolder.Name
newSheet.Cells(nextRow, 2).Value = folderPath
indent = indent + 1
nextRow = nextRow + 1
For Each subFolder In thisFolder.SubFolders
    RecurseFolder subFolder.Path
Next subFolder
indent = indent - 1


End Sub