Excel Forum

Code: Select all

Sub ListFileInFolder()
Range("B3").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Clear

Range("B3").Select
Directory = [B1] & "\"
r = 2
ListFile = Dir(Directory, vbNormal)
Do While ListFile <> ""
r = r + 1
Cells(r, 2) = ListFile
ListFile = Dir()
Loop
End Sub

Code: Select all

Dim r As Long

Sub main()
    
    With Sheets(1).Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    
    With Sheets(1)
        .Range("A3").Value = "Folder Path:"
        .Range("B3").Value = "Folder Name:"
        .Range("C3").Value = "Size:"
        .Range("D3").Value = "Subfolders:"
        .Range("E3").Value = "Files:"
        .Range("F3").Value = "File Names:"
        .Range("A3:G3").Font.Bold = True
    End With
    ' and include subfolders (true/false)
    ListFolders "D:\Knowledge Warehouse\Excel", True
    Columns("A:F").AutoFit
End Sub


Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
    DoEvents
    Application.DisplayAlerts = False
    
    Dim fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    
    Set fso = New Scripting.FileSystemObject
    Set SourceFolder = fso.GetFolder(SourceFolderName)
    
    On Error Resume Next
    
    r = Range("F65536").End(xlUp).Row + 1
    
    With Sheets(1)
        .Cells(r, 1).Value = SourceFolder.Path
        .Cells(r, 2).Value = SourceFolder.Name
        .Cells(r, 3).Value = SourceFolder.Size
        .Cells(r, 4).Value = SourceFolder.SubFolders.Count
        .Cells(r, 5).Value = SourceFolder.Files.Count
    End With
    
    Findfiles (SourceFolder.Path)
    
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If
      
    Set SourceFolder = Nothing
    Set fso = Nothing

End Sub

Sub Findfiles(d As String)
    Dim fname As String
    
    fname = Dir(d & "\*.*")
    Do While fname <> ""
        Sheets(1).Cells(r, 6).Value = fname
        r = r + 1
        fname = Dir
    Loop
    
End Sub