create headers based on match folders & brings the files with hyperlink

[Alaa mg]

Hello Guys !
I need macro to create the headers in row1 based on matching folders names and brings all of files under headers based on matching folder name .
so in this directory "C:\Users\Ala-PC\Desktop\FILES" contains folder's name is report and the folder REPORT contains many folders and the folders contain different file extensions .
so what I want create the headers in row 1 based on on matching folder name and brings all of the files under headers and hyperlink to open any file where the folder and files are existed in folder report
for instance if I have folders names PURCHASE, SALES , STOCKS then the headers in row1 should be in columns A,B,C= PURCHASE, SALES , STOCKS and brings all of the files under header which is matched for folder name and if increase folders then should increase columns D,E ... and so on based on how many folders are existed in folder REPORT .
thanks

 

[John_w]

Try this macro.

Public Sub List_Files_In_Subfolder_Columns()
    
    Dim mainFolder As String
    Dim subfolders As Collection, c As Long
    Dim files As Collection, r As Long
    
    mainFolder = "C:\Users\Ala-PC\Desktop\FILES\REPORT\"
    
    Set subfolders = Get_Subfolders(mainFolder)
    
    With ActiveSheet
        .Cells.ClearContents
        For c = 1 To subfolders.Count
            Set files = Get_Files(subfolders(c))
            .Cells(1, c).Value = Mid(subfolders(c), InStrRev(subfolders(c), "\") + 1)
            For r = 1 To files.Count
                .Hyperlinks.Add Anchor:=.Cells(r + 1, c), Address:=subfolders(c) & "\" & files(r), TextToDisplay:=files(r)
            Next
        Next
    End With

End Sub


Private Function Get_Subfolders(ByVal folderPath As String) As Collection

    Dim folderName As String
    
    'Returns a collection of subfolder paths in the specified folder
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    Set Get_Subfolders = New Collection
    folderName = Dir(folderPath, vbDirectory)
    While folderName <> vbNullString
        If (GetAttr(folderPath & folderName) And vbDirectory) <> 0 Then
            If folderName <> "." And folderName <> ".." Then
                Get_Subfolders.Add folderPath & folderName
            End If
        End If
        folderName = Dir
    Wend
        
End Function


Private Function Get_Files(ByVal folderPath As String) As Collection

    Dim fileName As String
    
    'Returns a collection of file names in the specified folder
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    Set Get_Files = New Collection
    fileName = Dir(folderPath, vbDirectory)
    While fileName <> vbNullString
        If (GetAttr(folderPath & fileName) And vbDirectory) = 0 Then
            Get_Files.Add fileName
        End If
        fileName = Dir
    Wend
        
End Function

 

[Alaa mg]

Hi John ,
it's perfect , but I forgot to mention about the headers should alsoaloow me open the folder . I mean when press the cell contain header should open the folder. sorry about it

 

[John_w]

the headers should alsoaloow me open the folder

Replace the .Cells(1, c).Value line with something very similar to the .Hyperlinks.Add line. I leave that as a little exercise for you, but post back if you need help.

 

[Alaa mg]

I try change this

.Cells(1, c).Value = Mid(subfolders(c), InStrRev(subfolders(c), "\") + 1)

to

.Hyperlinks.Add Anchor:=.Cells(1, c).Value, Address:=Mid(subfolders(c), InStrRev(subfolders(c), "\") + 1)

but doesn't work

 

[John_w]

            .Hyperlinks.Add Anchor:=.Cells(1, c), Address:=subfolders(c), TextToDisplay:=Mid(subfolders(c), InStrRev(subfolders(c), "\") + 1)

 

[Alaa mg]

thanks , but the code becomes just getting the headers without brings the files . what's wrong?

 

[John_w]

Have you replaced the .Cells(1, c).Value line with the code in my previous post?

 

[Alaa mg]

my bad ! sorry .
it's perfect . much appreciated for your assistance
have a nice weekend !