0 votes
in VBA by Beginner (69 points)

hello  

i have  this  code  works  well   actually i search  so  much  in the internet  to  do what  i want   but  i don't find any thing  this  code  bring  all my files from subfolder and hyperlink to open my files   in one column in b   but  what  i want  make  column a is  a path  folders  and  column b is  the  name   of subfolder  and   the  c  the name of  file  each subfolder  and hyperlink  to  open the files   

i hope some  body  help  me 

Option Explicit

Public FSO As New FileSystemObject
Private FileType As Variant


Sub ListHyperlinkFilesInSubFolders()

    Dim StartingCell As String 'Cell where hyperlinked list starts
    Dim FSOFolder As Folder
    Dim RootFolder As String

    Application.ScreenUpdating = False
   
    StartingCell = ActiveCell.Address


    With Application.FileDialog(msoFileDialogFolderPicker)
    
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select folder to list files from"
        .Show
    
        'If a folder has been selected
        If .SelectedItems.Count <> 0 Then
        
            RootFolder = .SelectedItems(1)
            
            Set FSOFolder = FSO.GetFolder(RootFolder)
            
            'Ask what type of files to look for
            FileType = Application.InputBox("* and ? wildcards are valid " & vbCrLf & vbCrLf & " e.g. .xls* to list XLS, XLSX and XLSM" _
                        & vbCrLf & vbCrLf & "??st.* to list West.xlsx and East.xlsx" & vbCrLf & vbCrLf & "Just click OK to list all files.", _
                        "What type of files do you want to list?", "")
                        
            If FileType = False Then 'Cancel pressed
                
                MsgBox "Process Cancelled"
                Exit Sub

            ElseIf FileType = vbNullString Then 'Nothing entered and OK pressed

                FileType = "*.*"
            
            End If
            
            
            ActiveSheet.Cells.Clear

            
            With Range(StartingCell)
            
                .ClearFormats
                .Value = "No " & FileType & " files found in " & RootFolder
                .Select
                
            End With
            
           
            ListFilesInSubFolders FSOFolder, ActiveCell
    
            'Autofit the columns containing our results
            Columns.AutoFit
            
        Else
        
            'If no folder selected, admonish user for wasting CPU cycles :)
            MsgBox "No folder selected.", vbExclamation
        
        End If

    End With
    
    Application.ScreenUpdating = True

End Sub



Sub ListFilesInSubFolders(StartingFolder As Scripting.Folder, DestinationRange As Range)
    
    Dim CurrentFilename As String
    Dim OffsetRow As Long
    Dim TargetFiles As String
    Dim SubFolder As Scripting.Folder

    DestinationRange.Value = StartingFolder.Path
    
   
    TargetFiles = StartingFolder.Path & "\" & FileType
                
            CurrentFilename = Dir(TargetFiles, 7)
            
            OffsetRow = 1
            
            Do While CurrentFilename <> ""
            

                DestinationRange.Offset(OffsetRow).Hyperlinks.Add Anchor:=DestinationRange.Offset(OffsetRow), Address:=StartingFolder.Path & "\" & CurrentFilename, TextToDisplay:=CurrentFilename
                
                OffsetRow = OffsetRow + 1

               
                CurrentFilename = Dir
        
            Loop

    Set DestinationRange = DestinationRange.Offset(OffsetRow)
    
     For each  SubFolder In StartingFolder.SubFolders
        
        ListFilesInSubFolders SubFolder, DestinationRange
        
    Next SubFolder
    
    
    End Sub

 

 

thank

 

 

 

1 Answer

0 votes
by Expert (911 points)
selected by
 
Best answer

See these tutorials:
VBA Loop Through Files in Folder
VBA Select Folder with msoFileDialogFolderPicker
Introduction to the VBA FileSystemObject
List Files in Folder and Subfolders with VBA

Try this:

Option Explicit

Private FileType As Variant

Sub ListHyperlinkFilesInSubFolders()

    'See https://wellsr.com/vba/2016/excel/vba-loop-through-files-in-folder/
    'See https://wellsr.com/vba/2016/excel/vba-select-folder-with-msoFileDialogFolderPicker/
    'See https://wellsr.com/vba/2018/excel/introduction-to-the-vba-filesystemobject/
    'See https://wellsr.com/vba/2018/excel/list-files-in-folder-and-subfolders-with-vba-filesystemobject/
    Dim FSO As Scripting.FileSystemObject 'VBE: Tools > References > Microsoft Scripting Runtime
    Set FSO = New Scripting.FileSystemObject
    
    Dim StartingCell As String 'Cell where hyperlinked list starts
    Dim FSOFolder As Folder
    Dim RootFolder As String

    Application.ScreenUpdating = False
    StartingCell = ActiveCell.Address
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select folder to list files from"
        .Show
        'If a folder has been selected
        If .SelectedItems.Count <> 0 Then
            RootFolder = .SelectedItems(1)
            Set FSOFolder = FSO.GetFolder(RootFolder)
            'Ask what type of files to look for
            FileType = Application.InputBox( _
                "* and ? wildcards are valid " & vbCrLf & vbCrLf & _
                " e.g. .xls* to list XLS, XLSX and XLSM" & vbCrLf & vbCrLf & _
                "??st.* to list West.xlsx and East.xlsx" & vbCrLf & vbCrLf & _
                "Just click OK to list all files starting at cell " & StartingCell & ".", _
                "What type of files do you want to list?", "")
            If FileType = False Then 'Cancel pressed
                MsgBox "Process Cancelled"
                Exit Sub
            ElseIf FileType = vbNullString Then 'Nothing entered and OK pressed
                FileType = "*.*"
            End If
            ActiveSheet.Cells.Clear
            With Range(StartingCell)
                .ClearFormats
                .Value = "No " & FileType & " files found in " & RootFolder
                .Select
            End With
            ListFilesInSubFolders FSOFolder, ActiveCell, False
            'Autofit the columns containing our results
            Columns.AutoFit
        Else
            'If no folder selected, admonish user for wasting CPU cycles :)
            MsgBox "No folder selected.", vbExclamation
        End If
    End With
    
    Application.ScreenUpdating = True

End Sub

Sub ListFilesInSubFolders(StartingFolder As Folder, DestinationRange As Range, IsSubFolder As Boolean)
    
    Dim CurrentFilename As String
    Dim OffsetRow As Long
    Dim TargetFiles As String
    Dim SubFolder As Folder

    If IsSubFolder Then
        DestinationRange.Value = StartingFolder.ParentFolder.Path
        DestinationRange.Offset(0, 1).Value = StartingFolder.Name
        ActiveSheet.Hyperlinks.Add _
            Anchor:=DestinationRange.Offset(0, 1), _
            Address:=StartingFolder.Path
    Else
        DestinationRange.Value = StartingFolder.Path
        ActiveSheet.Hyperlinks.Add _
            Anchor:=DestinationRange, _
            Address:=StartingFolder.Path
    End If
    TargetFiles = StartingFolder.Path & "\" & FileType
    CurrentFilename = Dir(TargetFiles, 7)
    OffsetRow = 0
    Do While CurrentFilename <> ""
        DestinationRange.Offset(OffsetRow, 2).Value = CurrentFilename
        ActiveSheet.Hyperlinks.Add _
            Anchor:=DestinationRange.Offset(OffsetRow, 2), _
            Address:=StartingFolder.Path & "\" & CurrentFilename
        OffsetRow = OffsetRow + 1
        CurrentFilename = Dir
    Loop
    Set DestinationRange = DestinationRange.Offset(OffsetRow)
    For Each SubFolder In StartingFolder.SubFolders
        ListFilesInSubFolders SubFolder, DestinationRange, True
    Next SubFolder
    
End Sub

Notice  Sub ListFilesInSubFolders  is called recursively.

When you post a question, please oblige us by responding to comments and answers.

by Beginner (69 points)
well, done ! jwoolley  the  updating is  perfect   thanks  so  much
by Expert (911 points)

You're welcome. You might also be interested in My Excel Toolbox.

Welcome to wellsr Q&A
Ask any questions you have about VBA and Python and our community will help answer them. wellsr Q&A is the standalone question and answer platform for wellsr.com. If you have a question about one of our specific tutorials, please include a link back to the tutorial.

Getting Started
Register
VBA Cheat Sheets (On Sale Now)

Looking for something else? Hire our team directly through ourVBA Help page, instead.

For more programming tips visit the VBA Tutorials Blog and the Python Tutorials Blog.

...