Excel Forum

Code: Select all

For i = 1 To r
Path = "\\Lbox\eds\DCC\Register\Drawing Control Copy SCAN\" & Range("g" & i).Value
Set fso = New Scripting.FileSystemObject
Set fldr = fso.GetFolder(Path)
x = Range("a" & Rows.Count).End(xlUp).Offset(1, 0).Row
For Each fil In fldr.Files
s.Sheets("Reg").Cells(x, 1) = fso.GetBaseName(fil.Name)
x = x + 1
Next fil
Next i

Code: Select all

Path = "\\Lbox\eds"
Set fso = New FileSystemObject
Set basefolder = fso.GetFolder(Path)
Set SubFolders = basefolder.SubFolders
l = 1
For Each folder In SubFolders
    Set files = folder.files
    For Each File In files
    If Right(File.Name, 4) = ".pdf" Then
    With Sheets("Reg")
        .Cells(l, 1).Value = fso.GetBaseName(File.Name)
    l = l + 1
    End With
    End If
    Next File
Next folder

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 = "C:\Downloads\test", 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 & "\*.pdf*")
    Do While fname <> ""
        Sheets(1).Cells(r, 6).Value = fname
        r = r + 1
        fname = Dir
    Loop
    
End Sub