bring files from folders and subfolders to multiple columns based on folders names

[tubrak]

hi

I need macro to brings all files from folder and subfolders to multiple columns so my directory isle "C:\Users\mm\Desktop\FILES" it contains many subfolders FILE1 up to FILE 6 and it's increasable and each subfolder contain files are different in extensions so it should create the headers based on subfolders names and bring the files for each column separately and hyperlink to open them
this should result after run macro

Microsoft Excel Worksheet .xlsx
	A	B	C	D	E	F
1	FILE1	FILE2	FILE3	FILE4	FILE5	FILE6
2	INV1.PDF	IMAGE1.JPG	PUR1.XLSM	MUSIC1.MP3	MOVIE1.MP4	FILE1.DOCX
3	INV2.PDF	IMAGE2.JPG	PUR2.XLSM	MUSIC2.MP3	MOVIE2.MP4	FILE2.DOCX
4	INV3.PDF	IMAGE3.JPG	PUR3.XLSM	MUSIC3.MP5		FILE3.DOCX
5	INV4.PDF	IMAGE4.JPG	PUR4.XLSM	MUSIC4.MP6		FILE4.DOCX
6	INV5.PDF	IMAGE5.JPG	PUR5.XLSM
7	INV6.PDF	IMAGE6.JPG	PUR6.XLSM
8	INV7.PDF	IMAGE7.JPG	PUR7.XLSM
9	INV8.PDF	IMAGE8.JPG	PUR8.XLSM
10	INV9.PDF	IMAGE9.JPG	PUR9.XLSM
11	INV10.PDF		PUR10.XLSM
12	INV11.PDF		PUR11.XLSM
Sheet1

 

[tubrak]

thanks very much for your solution
I have some question when I create the formatting and borders the code it deletes it may you fix it ,please and if there is way hide hyperlink without show underline and blue color it will be great
and if it's possible I would press the headers then open the folder
thanks again

 

[Sequoyah]

Hi again,
try this:

Sub Test3()
    
    'https://www.mrexcel.com/board/threads/bring-files-from-folders-and-subfolders-to-multiple-columns-based-on-folders-names.1172585/
    
    Dim oFSO As Object
    Dim folder As Object
    Dim subfolders As Object
    Dim xFile As Object
    Dim Wks As Worksheet
    Dim rowIndex As Long
    Dim Col As Integer
    
    Col = 1
    rowIndex = 2
    
    Set Wks = ThisWorkbook.Sheets("Foglio1")        '==>> TO ADAPT
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set folder = oFSO.GetFolder("C:\Users\39320\Desktop\Forum")        '==>> TO ADAPT
    Set subfolders = folder.subfolders
    
    Application.ScreenUpdating = False
    
    Wks.UsedRange.ClearContents
    
    For Each subfolders In folder.subfolders
        
        With Wks.Cells(1, Col)
            .Value = subfolders.Name
            .Hyperlinks.Add Anchor:=Wks.Cells(1, Col), Address:=subfolders
            .Font.Color = vbBlack
            .Font.Underline = xlUnderlineStyleNone
        End With
        
        For Each xFile In subfolders.Files
            
            With Application.ActiveSheet.Cells(rowIndex, Col)
                .Formula = xFile.Name
                .Hyperlinks.Add Anchor:=Cells(rowIndex, Col), Address:=subfolders & "\" & xFile.Name
                .Font.Color = vbBlack
                .Font.Underline = xlUnderlineStyleNone
            End With
            
            rowIndex = rowIndex + 1
        Next xFile
        
        Col = Col + 1
        rowIndex = 2
    Next subfolders
    
    Wks.Columns.AutoFit
    
    Application.ScreenUpdating = True
    
    Set oFSO = Nothing
    Set folder = Nothing
    Set subfolders = Nothing
    
End Sub

 

[Marc L]

I run this Sub Demo1() but shows in cell A1 " Nothing !"

As it well works on my side since last century with different Excel versions & computers so check the path in the constant P …​

​

 

[tubrak]

@Marc L I re copy the path but it just shows main folder name is FILE as in my directory

 

[tubrak]

@Sequoyah great code !
your super legend! thanks for your help