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

 

[Marc L]

Hi, a VBA demonstration for starters to paste to the worksheet module :​

Function DirList(SCAN$, Optional FOLD$, Optional ATTR As VbFileAttribute = vbNormal) As String()
         Dim B%, D$, F$, T$(), U&
    With Application
        If FOLD > "" Then
            If Right(FOLD, 1) <> .PathSeparator And Left(SCAN, 1) <> .PathSeparator Then FOLD = FOLD & .PathSeparator
            D = FOLD
        Else
            D = Left$(SCAN, InStrRev(SCAN, .PathSeparator))
        End If
    End With
        If SCAN = "." Then SCAN = "*."
        On Error Resume Next
        F = Dir(FOLD & SCAN, ATTR)
    Do Until F = ""
        If ATTR And vbDirectory Then B = Right(F, 1) = "." Or (GetAttr(D & F) And vbDirectory) = 0
        If B = 0 Then U = U + 1: ReDim Preserve T(1 To U): T(U) = FOLD & F
        F = Dir
    Loop
         DirList = IIf(U, T, Split(""))
End Function

Sub Demo1()
  Const M = " Scanning …", P = "C:\Users\mm\Desktop\FILES\", S = "\"
    Dim D$(), C%, H$(), R&
        UsedRange.Clear
        [A1].Value = M
        Application.ScreenUpdating = False
        D = DirList(P, , vbDirectory)
    For C = 1 To UBound(D)
        Cells(C).Value2 = D(C)
        H = DirList(P & D(C) & S)
    For R = 1 To UBound(H)
        Hyperlinks.Add Cells(R + 1, C), P & D(C) & S & H(R), , , H(R)
    Next R, C
        If [A1].Text = M Then [A1] = " Nothing !": Beep Else UsedRange.Columns.AutoFit
        Application.ScreenUpdating = True
End Sub

 

[tubrak]

gives error object required

UsedRange.Clear

 

[Marc L]

​

Your bad as « solution belongs to good enough readers » so paste the demonstration where it must be just following the dark red direction above the code !​

 

[tubrak]

not my bad I put the whole code in worksheet module

 

[Marc L]

​

Yes your bad as this error comes only when the code is not located in a worksheet module like in your picture where it's a general / standard module ‼ ​

So just open above the worksheet module of 'sheet1' or 'sheet2' …​

 

[tubrak]

forgive me how code works I run this Sub Demo1() but shows in cell A1 " Nothing !"

 

[Sequoyah]

Hi all,
here's my attempt, copy the code in a standard module, adapt sheet name and path if needed.

Sub Test()
    
    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("Sheet1")        '==>> TO ADAPT
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set folder = oFSO.GetFolder("C:\Users\mm\Desktop\FILES")        '==>> TO ADAPT
    Set subfolders = folder.subfolders
    
    Application.ScreenUpdating = FALSE
    
    Wks.UsedRange.Clear
    
    For Each subfolders In folder.subfolders
        
        Wks.Cells(1, Col).Value = subfolders.Name
        
        For Each xFile In subfolders.Files
            Application.ActiveSheet.Cells(rowIndex, Col).Formula = xFile.Name
            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

 

[tubrak]

@Sequoyah thanks you ! you barley did it just it remains some things , hyperlink the files to I can open them

 

[Sequoyah]

Hi *tubrak,
thanks for your feedback. I apologize for not reading your request carefully, add this code after the line

Application.ActiveSheet.Cells(rowIndex, Col).Formula = xFile.Name

  With ActiveCell
    .Hyperlinks.Add Anchor:=Cells(rowIndex, Col), Address:=subfolders & "\" & xFile.Name
  End With