我搜索了其他问题，但无法找到我需要的东西。 我有一个文件夹丢失了子文件夹，其中有很多子文件夹，依此类推，直到我找到其中数百个文件的列表。
我需要Excel中的宏来列出给定目录的每个子文件夹中的文档，并且还要超链接到文档。
我找到了一个宏，它将列出文档并在1个目录中创建一个超链接，但不会深入研究子目录。
我希望有人可以提供帮助。
感谢。
汤姆
我使用的宏是：
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
当前更新： '起始行的全球宣言
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
上面的问题是超链接 我想要超级链接在同一个细胞中，文件的名称是在超级链接结束时，我的活动是什么，在我使用MACRO并且是名字并且链接到最终发现的文件之前
答案 0 :(得分：0)
我昨天刚刚做了，除了超链接之外。
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
*编辑，覆盖了一些单元格
答案 1 :(得分：0)
试试这个。这是我的一个邮件宏的一部分，它挖掘文件夹和子文件夹，并列出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