VBA Directory Cycle

[smit3446]

I'm trying to create a two-dimensional loop that loops through a file path that puts the folder name in one column, and then the files in that folder in the second column. The output should look like this:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Folder 1
[/TD]
[TD]File name 1[/TD]
[/TR]
[TR]
[TD]Folder 1[/TD]
[TD]File name 2
[/TD]
[/TR]
[TR]
[TD]Folder 1[/TD]
[TD]File name 3[/TD]
[/TR]
[TR]
[TD]Folder 2[/TD]
[TD]File name 1[/TD]
[/TR]
[TR]
[TD]Folder 3[/TD]
[TD]File name 1[/TD]
[/TR]
[TR]
[TD]Folder 3[/TD]
[TD]File name 2[/TD]
[/TR]
[TR]
[TD]Folder 3[/TD]
[TD]File name 3[/TD]
[/TR]
[TR]
[TD]Folder 3[/TD]
[TD]File name 4[/TD]
[/TR]
[TR]
[TD]Folder 4[/TD]
[TD]File name 1[/TD]
[/TR]
[TR]
[TD]Folder 4[/TD]
[TD]File name 2[/TD]
[/TR]
</tbody>[/TABLE]


Whenever I run my current macro, it's timing out and I'm not sure what's going on. Here's my current code:

Sub Iterate_Folders()Dim Row As Integer
Dim column As Integer
Dim Path As String
Dim Folder As String
Dim File As String




Row = 1
Path = "R:\Reinsurers\2. Bios\"   ' Path should always contain a '\' at end
Folder = Dir(Path, vbDirectory)   ' Retrieving the first entry.
File = Dir(Path & Folder & "\")
MsgBox File




Do Until Folder = ""   ' Start the folder loop.
  If (GetAttr(Path & Folder) And vbDirectory) = vbDirectory Then
    
    If Path & Folder & "\" <> "" Then
        ActiveSheet.Cells(Row, 1).Value = Folder
        
        Do Until File = ""
            If (GetAttr(Path & Folder & "\" & File) And vbDirectory) = vbDirectory Then
                
                If Path & Folder & "\" & File <> "" Then
                    ActiveSheet.Cells(Row, column).Value = File
                End If
            
            End If
         Loop
        
    End If
        
    
    Row = Row + 1
  End If
  Folder = Dir()   ' Getting next entry.
Loop
End Sub

If I take out the second dimension that grabs the file names, I can correctly get the macro to grab the folder name and print them in Column A. However, when I add in the second-dimension loop, it times out and my computer is seemingly about to explode. Any help is appreciated. Thank you!

 

[smit3446]

I've updated my code below, which now doesn't time out, but doesn't go to the next folder when I run the macro. It will keep posting Folder 1 File 1 over and over. Any help is appreciated, thank you!

Sub Iterate_Folders()Dim Row As Integer
Dim Path As String
Dim Folder As String
Dim File As String




Row = 1
Path = "R:\Reinsurers\2. Bios\"   ' Path should always contain a '\' at end
Folder = Dir(Path, vbDirectory)   ' Retrieving the first entry.
File = Dir(Path & Folder)


Do Until Folder = ""   ' Start the folder loop.
  If (GetAttr(Path & Folder) And vbDirectory) = vbDirectory Then
    
    If Path & Folder & "\" <> "" Then
                
        Do Until File = ""


            If (GetAttr(Path & Folder & "\" & File) And vbNormal) = vbNormal Then
                ActiveSheet.Cells(Row, 1).Value = Folder
                If Path & Folder & "\" & File <> "" Then
                    ActiveSheet.Cells(Row, 2).Value = File
                End If
            
            End If
            Row = Row + 1
         Loop
        
    End If
        
    
    Row = Row + 1
  End If
  Folder = Dir()   ' Getting next entry.
Loop
End Sub

 

[John_w]

Logically, your code needs Dir function calls at the start of and inside the inner File loop. However, that won't work because you can't nest Dir function calls - VBA loses context of its place in the outer Dir loop.

Instead, use separate Dir loops. The first loops through all the subfolders and puts them in an array. Then for each subfolder array item do another Dir loop to loop through the files in that subfolder.

Sub Iterate_Folders()

    Dim path As String
    Dim folder As Variant
    Dim subfoldersArray() As String, numSubfolders As Long
    Dim fileName As String
    Dim row As Long

    ActiveSheet.Cells.Clear
    
    path = "R:\Reinsurers\2. Bios\"
    If Right(path, 1) <> "\" Then path = path & "\"  ' Ensure Path ends with '\'
    
    numSubfolders = 0
    folder = Dir(path, vbDirectory)   ' Retrieving the first folder
    Do Until folder = vbNullString
        If (GetAttr(path & folder) And vbDirectory) = vbDirectory Then
            If folder <> "." And folder <> ".." Then
                ReDim Preserve subfoldersArray(numSubfolders)
                subfoldersArray(numSubfolders) = folder
                numSubfolders = numSubfolders + 1
            End If
        End If
        folder = Dir()
    Loop
    
    row = 1
    For Each folder In subfoldersArray
        fileName = Dir(path & folder & "\*.*", vbNormal)
        Do Until fileName = vbNullString
            ActiveSheet.Cells(row, 1).Value = folder
            ActiveSheet.Cells(row, 2).Value = fileName
            row = row + 1
            fileName = Dir()
        Loop
    Next
        
End Sub