excel VBA 宏以获取文件夹和所有子文件夹中的文档列表以及指向它们的超链接

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

提问by user3524782

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.

我需要 Excel 中的宏来列出给定目录的每个子文件夹中的文档以及指向文档的超链接。

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.

我找到了一个宏，它会列出文档并在 1 目录中创建指向它们的超链接，但不会深入研究子目录。

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:\Users\Thomas\Documents\test 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

上面的问题是超链接我希望超链接位于文件名称所在的同一个单元格中，但是超链接在我运行宏之前处于活动状态的任何单元格中结束，并且是名称和链接找到最终文件

回答by n8.

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

*编辑，正在覆盖一些单元格

回答by PraSon

Try this one. this is part of one of my mail macro where it digs into the folders and subfolders and list all the files on the sheet1. See if you can adjust this as per your need.

试试这个。这是我的一个邮件宏的一部分，它深入文件夹和子文件夹并列出 sheet1 上的所有文件。看看您是否可以根据需要调整它。

Sub foldersubFiles()

Dim fs$, f
Sheets("Sheet 1").Activate
fs = "C:\Users\"    ' path of your main folder
f = Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & _
fs & """ /b/s").StdOut.ReadAll, vbCrLf)  'look in all sub folders
[a:a].ClearContents
[a1].Resize(UBound(f)).Value = Application.WorksheetFunction.Transpose(f)

End Sub