Accessing sub folders in a folder

[Raju Kumar Singh]

Hello everyone,

I want to access all files available in a folder and its all sub folder. I have written VBA code shown below using file system object, but it is not working. Please check, what mistake is underlying.



Sub checking_files_in_multiple_folders_and_subfolders(mainpath As String)


Dim fso As Scripting.FileSystemObject
Dim fol As Scripting.Folder
Dim subfol As Scripting.Folder
Dim fil As Scripting.File
Dim mainpath As String, var1 As Byte
var1 = 1


mainpath = "D:\Excel n VBA\VBA scenarios\FSO\Recursive loop"
'**********mysht is a code name of sheet1**********
With mysht
.Range("A1").Value = "File name"
.Range("B1").Value = "File Size"
.Range("C1").Value = "Date Created"
.Range("A1").Select
End With


Set fso = New Scripting.FileSystemObject
Set fol = fso.GetFolder(mainpath)
For Each fil In fol.Files
ActiveCell.Offset(var1, 0).Value = fil.Name
ActiveCell.Offset(var1, 1).Value = fil.Size
ActiveCell.Offset(var1, 2).Value = fil.DateCreated
var1 = var1 + 1
Next fil


For Each subfol In fol.SubFolders
mypath = subfol.path
Call checking_files_in_multiple_folders_and_subfolders(subfol.path)
Next subfol
End Sub


Thanks

 

[DanteAmor]

Try this

Option Explicit
Dim rutas As New Collection
'
Sub Listar_Archivos()
    Dim ruta As String, ext As String, h1 As Worksheet, atributos As Object, arch As Variant
    Dim fila As Long, sd As Variant
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ruta = "C:\trabajo\archivos"        'initial folder
    ext = "xls*"                        'extension
    '
    Set h1 = Sheets(1)                  'output sheet
    h1.Columns("A:F").ClearContents
    h1.Range("A1:D1").Value = Array("Folder", "File", "Date Created", "Size")
    '
    Set atributos = CreateObject("Scripting.FileSystemObject")
    rutas.Add ruta
    Call AgregaDir(ruta)
    fila = 2
    For Each sd In rutas
        arch = Dir(sd & "\*." & ext)
        Do While arch <> ""
            h1.Cells(fila, "A").Value = sd
            h1.Cells(fila, "B").Value = arch
            h1.Cells(fila, "C").Value = atributos.GetFile(sd & "\" & arch).DateCreated
            h1.Cells(fila, "D").Value = atributos.GetFile(sd & "\" & arch).Size
            fila = fila + 1
            arch = Dir()
        Loop
    Next
    '
    Set rutas = Nothing
    Application.ScreenUpdating = True
    MsgBox "Depurar archivos", vbInformation, "ARCHIVOS"
End Sub
'
Sub AgregaDir(lpath)
    Dim SubDir As New Collection, DirFile As Variant, sd As Variant
    If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
    DirFile = Dir(lpath & "*", vbDirectory)
    Do While DirFile <> "" 'add subdirectorios a collection
        If DirFile <> "." And DirFile <> ".." Then _
            If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
                SubDir.Add lpath & DirFile
        DirFile = Dir
    Loop
    For Each sd In SubDir
        rutas.Add sd
        Call AgregaDir(sd)
    Next
End Sub

 

[Raju Kumar Singh]

Hi DanteAmor,

Thank you for the provided code.
However, I am unable to fully understand the solutions. IF possible, could you please let me know where I made mistake in my line of code.

 

[DanteAmor]

Hi DanteAmor,

Thank you for the provided code.
However, I am unable to fully understand the solutions. IF possible, could you please let me know where I made mistake in my line of code.

Did you try the code I sent you? It works for me.

 

[Raju Kumar Singh]

Did you try the code I sent you? It works for me.

Hi, I havn't tried yet. Before that I thought to understand it.

however as you said, I will try to run it in my system and let you know.

 

[DanteAmor]

Hi, I havn't tried yet. Before that I thought to understand it.

however as you said, I will try to run it in my system and let you know.

Please, try and I'll gladly explain any questions you have in the code.
It will be easier to explain my code than to review yours, test it, correct it, understand it and then explain it to you.