List All SubFolders In A Folder Excel 2013

[PY_]

I am having the hardest time searching for a macro that will list all folders and subfolders using VB. Does anyone have one that will work with Excel 2013? If i had a choice, i would like all folders to be listed in column A of Sheet1. So sub folders would not slide to the next column, they will just remain under column A.

[jaslake]

Hi PV

This works in Excel 2010...don't have 2013

Option Explicit
Sub ListAllFile()

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim ws As Worksheet

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = Sheets("Sheet1")

    'Get the folder object associated with the directory
    Set objFolder = objFSO.GetFolder("C:\")  '<-----Change this line to suit
    With ws
        .Cells.Clear
        .Cells(1, 1).Value = "The files found in " & objFolder & " are:"
    End With

    'Loop through the Files collection
    FindFilesInAllFolders objFolder, True   '<-----Change this line to True to list all subdirectories

    '    For Each objFile In objFolder.Files
    '        ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
    '    Next

    'Clean up!
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing
    ws.Columns.AutoFit

End Sub

'http://www.excelforum.com/excel-programming/764746-exclude-files-from-getopenfilename-based-on-file-name.html#post2474970
'Written: March 24, 2010
'Author:  Leith Ross
'Summary: List all files in a single folder or all files in the subfolders of the parent
'         folder on the ActiveSheet. The file name, date and time it was last modified
'         are listed in column "A:B" starting at row 1.
'Adapted by jaslake 03/29/2011 and 04/21/2013
Sub FindFilesInAllFolders(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim LR As Long
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    For Each FileItem In SourceFolder.Files
        With Sheets("Sheet1")
            LR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
            .Cells(LR, "A") = SourceFolder    '& FileItem.Name
            .Cells(LR, "B") = FileItem.Name
        End With
    Next FileItem
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            FindFilesInAllFolders SubFolder.Path, True
        Next SubFolder
    End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Sub

[PY_]

That is close! I will see if i can modify it to fit my needs. Do you know how to modify it so it only lists Folder names? If it can remove the folder paths that would be even better.

[jaslake]

Hi PV

Try changing this line of Code

For Each FileItem In SourceFolder.Files
        With Sheets("Sheet3")
            LR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
            .Cells(LR, "A") = Split(SourceFolder, "\")(1)   '& FileItem.Name '<-----Change this line
            .Cells(LR, "B") = FileItem.Name
        End With
    Next FileItem

[PY_]

No that is still listing the files and multiple lines per folder.

I'm looking for a result similar to this if i ran it for C:\

All of this will be in a single column A:
Program Files
Sub Folder(s) of Program Files
Sub Folder(s) of each Sub Folder Inside Program Files
Sub Folder(s) of each Sub Folder of......etc
Windows
Sub Folder(s) of Windows
Sub Folder(s) of each Sub Folder Inside Windows
Sub Folder(s) of each Sub Folder of......etc
Etc...etc...

[Kenneth Hobson]

Sub ken()
  Dim a() As String
  a() = Split(CreateObject("Wscript.Shell").exec("cmd /c dir x:\*.* /ad /s /b").stdout.readall, vbLf)
  Range("A1").Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
  Columns("A:A").EntireColumn.AutoFit
End Sub

[PY_]

That works!
Is it possible to NOT show the subfolder information to the left so it only shows the folder name and not the path?

I was able to display just the folder name using this code in B1 copied down but if it can be done using vba, that would be less coding on the worksheet.

=TRIM(RIGHT(SUBSTITUTE(A1,"\",REPT(" ",LEN(A1))),LEN(A1)))

[Trebor76]

Hi PY_,

Try this:

Option Explicit
Sub Macro1()
  
    
    Dim a() As String
    a() = Split(CreateObject("Wscript.Shell").exec("cmd /c dir u:\*.* /ad /s /b").stdout.readall, vbLf)
    Range("A1").Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
    
    With Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
        .Formula = "=TRIM(RIGHT(SUBSTITUTE(A1,""\"",REPT("" "",LEN(A1))),LEN(A1)))"
        .Value = .Value
    End With
        
    Columns("A:B").EntireColumn.AutoFit
    
End Sub

HTH

Robert

[PY_]

Robert, that worked great. I did tweak it a little because for me, i did not need the paths in A, just the names from B. Here is my final code and thanks again!

Option Explicit
Sub Macro1()
  
    Application.ScreenUpdating = False
    Clear.Cells

    Dim a() As String
    a() = Split(CreateObject("Wscript.Shell").exec("cmd /c dir u:\*.* /ad /s /b").stdout.readall, vbLf)
    Range("A1").Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
    
    With Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
        .Formula = "=TRIM(RIGHT(SUBSTITUTE(A1,""\"",REPT("" "",LEN(A1))),LEN(A1)))"
        .Value = .Value
    End With
        
    Columns("B").EntireColumn.Delete
    Columns("A").EntireColumn.AutoFit
    
    Application.ScreenUpdating = True

End Sub

[Kenneth Hobson]

PY. Your Clear.Cells should be Cells.Clear. I am not sure why you deleted Column B. I think that you meant column A.

Please note that this DIR method may translate characters. e.g. The Daily Dose of Excel website page when saved in the browser creates a folder name with some characters like >>. These are translated by this method into an upperscore character. While you may not ever see that, I wanted to note it for others.

It appears that folders like this:
x:\a
x:\a\b
x:\a\b\a
would become
a
b
a.

If that is what you wanted, the last subfolder name, I would parse the last subfolder name into in an array. Normally, I would use an FSO method but that method fails for the scenario noted.

Sub ken()
    Dim a() As String, i As Long, s As String, b() As String
    Cells.Clear
    
    a() = Split(CreateObject("Wscript.Shell").exec("cmd /c dir u:\*.* /ad /s /b").stdout.readall, vbLf)
    For i = LBound(a) To UBound(a) - 1
      s = Left(a(i), Len(a(i)) - 1)
      b() = Split(s, "\")
      a(i) = b(UBound(b))
    Next i
    Range("A1").Resize(UBound(a)).Value = WorksheetFunction.Transpose(a)
    
    Columns("A:A").EntireColumn.AutoFit
End Sub

I recently helped a poster do something similar though they just want the folders in a parent folder. I put those folder names into a Data Validation dropdown list. For that scenario, fso, or DIR() methods suffice.