excel VBA macro to get list of documents in folder and all subfolders and hyperlink to them

Question

I have searched other questions but cant find what I need. I have a folder with lost of sub folder, lots of sub folders in them and so on until I get to a list of hundreds of documents in them.

I need a macro in Excel to list the documents in every sub folder of a given directory and also hyperlink to the document.

I have found a macro that will list the documents and create a hyperlink to them in 1 directory but does not delve into the sub directories.

I'm hoping someone can help.

Thanks.

Tom

The macro I am using is:

Option Compare Text
Option Explicit

Function Excludes(Ext As String) As Boolean
    'Function purpose:  To exclude listed file extensions from hyperlink listing

Dim X, NumPos As Long

 'Enter/adjust file extensions to EXCLUDE from listing here:
X = Array("exe", "bat", "dll", "zip")

On Error Resume Next
NumPos = Application.WorksheetFunction.Match(Ext, X, 0)
If NumPos > 0 Then Excludes = True
On Error GoTo 0

End Function

Sub HyperlinkFileList()
 'Macro purpose:  To create a hyperlinked list of all files in a user
 'specified directory, including file size and date last modified
 'NOTE:  The 'TextToDisplay' property (of the Hyperlink object) was added
 'in Excel 2000.  This code tests the Excel version and does not use the
 'Texttodisplay property if using XL 97.

Dim fso As Object, _
ShellApp As Object, _
file As Object, _
SubFolder As Object, _
Directory As String, _
Problem As Boolean, _
ExcelVer As Integer

 'Turn off screen flashing
Application.ScreenUpdating = False

 'Create objects to get a listing of all files in the directory
Set fso = CreateObject("Scripting.FileSystemObject")

 'Prompt user to select a directory
Do
    Problem = False
    Set ShellApp = CreateObject("Shell.Application"). _
    Browseforfolder(0, "Please choose a folder", 0, "c:")

    On Error Resume Next
     'Evaluate if directory is valid
    Directory = ShellApp.self.Path
    Set SubFolder = fso.GetFolder(Directory).Files
    If Err.Number <> 0 Then
        If MsgBox("You did not choose a valid directory!" & vbCrLf & _
        "Would you like to try again?", vbYesNoCancel, _
        "Directory Required") <> vbYes Then Exit Sub
        Problem = True
    End If
    On Error GoTo 0
Loop Until Problem = False

 'Set up the headers on the worksheet
With ActiveSheet
    With .Range("A1")
        .Value = "Listing of all files in:"
        .ColumnWidth = 40
         'If Excel 2000 or greater, add hyperlink with file name
         'displayed.  If earlier, add hyperlink with full path displayed
        If Val(Application.Version) > 8 Then 'Using XL2000+
            .Parent.Hyperlinks.Add _
            Anchor:=.Offset(0, 1), _
            Address:=Directory, _
            TextToDisplay:=Directory
        Else 'Using XL97
            .Parent.Hyperlinks.Add _
            Anchor:=.Offset(0, 1), _
            Address:=Directory
        End If
    End With
    With .Range("A2")
        .Value = "File Name"
        .Interior.ColorIndex = 15
        With .Offset(0, 1)
            .ColumnWidth = 15
            .Value = "Date Modified"
            .Interior.ColorIndex = 15
            .HorizontalAlignment = xlCenter
        End With
    End With
End With

 'Adds each file, details and hyperlinks to the list
For Each file In SubFolder
    If Not Excludes(Right(file.Path, 3)) = True Then
        With ActiveSheet
             'If Excel 2000 or greater, add hyperlink with file name
             'displayed.  If earlier, add hyperlink with full path displayed
            If Val(Application.Version) > 8 Then 'Using XL2000+
                .Hyperlinks.Add _
                Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
                Address:=file.Path, _
                TextToDisplay:=file.Name
            End If
             'Add date last modified, and size in KB
            With .Range("A65536").End(xlUp)
                .Offset(0, 1) = file.datelastModified

            End With
        End With
    End If
Next

End Sub

CURRENT UPDATE: 'Global Declaration for Start Row

Public lngRow As Long

Sub pReadAllFilesInDirectory()

Dim strFolderPath               As String
Dim BlnInclude_subfolder        As Boolean

'Set Path here
strFolderPath = "C:UsersThomasDocuments	est file"

'set start row
lngRow = 1

'Set this true if you want list of sub-folders as well
BlnInclude_subfolder = True

'---------- Reading of files in folders and sub-folders------
Call ListMyFiles(strFolderPath, BlnInclude_subfolder)
'---------- Reading of files in folders and sub-folders------

End Sub

Sub ListMyFiles(mySourcePath As String, blnIncludeSubfolders As Boolean)

Dim MyObject            As Object
Dim mySource            As Object
Dim mySubFolder         As Object
Dim myfile              As Object
Dim iCol                As Long

Set MyObject = CreateObject("Scripting.FileSystemObject")
Set mySource = MyObject.GetFolder(mySourcePath)

'Loop in each file in Folder
For Each myfile In mySource.Files

  iCol = 1
  Sheet1.Cells(lngRow, iCol).Value = myfile.Name  'File Name


       ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
    myfile.Path, TextToDisplay:=myfile.Name


    iCol = iCol + 1
    Sheet1.Cells(lngRow, iCol).Value = myfile.Path  'File Path/Location
   lngRow = lngRow + 1

Next

If blnIncludeSubfolders Then
    For Each mySubFolder In mySource.SubFolders
        Call ListMyFiles(mySubFolder.Path, True)
    Next
End If

THE PROBLEM WITH THE ABOVE IS THE HYPERLINK I WANT THE HYPERLINK TO BE IN THE SAME CELL THAT THE NAME OF THE FILE IS IN HOWEVER THE HYPERLINK ENDS UP IN WHAT EVER CELL WAS ACTIVE BEFORE I RAN THE MACRO AND IS THE NAME AND LINK TO THE FINAL FILE FOUND

Answer 1

I just did that yesterday, except for the hyperlink thing.

Sub startIt()

  Dim FileSystem As Object
  Dim HostFolder As String

  HostFolder = "C:whatever"

  Set FileSystem = CreateObject("Scripting.FileSystemObject")
  DoFolder FileSystem.GetFolder(HostFolder)

End Sub

Sub DoFolder(Folder)

  Dim SubFolder
  For Each SubFolder In Folder.SubFolders
    DoFolder SubFolder
  Next

  i = Cells(Rows.Count, 1).End(xlUp).Row + 1
  Dim File
  For Each File In Folder.Files
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:= _
        File.Path, TextToDisplay:=File.Name
    i = i + 1

  Next

End Sub

*Edit, was overwriting some cells