Excel宏列出包含目录中的所有文件和超链接他们

Question

我有一个宏已经但是我需要它也超链接列U中的文件与在列A

这里，文件列表一起是我的代码的权利现在，我如何添加超链接功能？ 我不介意如果我必须添加另一个模块。

Sub ListFilesAndSubfolders() 

    Dim FSO As Object 
    Dim rsFSO As Object 
    Dim baseFolder As Object 
    Dim file As Object 
    Dim folder As Object 
    Dim row As Integer 
    Dim name As String 

    'Get the current folder 
    Set FSO = CreateObject("scripting.filesystemobject") 
    Set baseFolder = FSO.GetFolder(ThisWorkbook.Path) 
    Set FSO = Nothing 

    'Get the row at which to insert 
    row = Range("A65536").End(xlUp).row + 1 

    'Create the recordset for sorting 
    Set rsFSO = CreateObject("ADODB.Recordset") 
    With rsFSO.Fields 
    .Append "Name", 200, 200 
    .Append "Type", 200, 200 
    End With 
    rsFSO.Open 

    ' Traverse the entire folder tree 
    TraverseFolderTree baseFolder, baseFolder, rsFSO 
    Set baseFolder = Nothing 

    'Sort by type and name 
    rsFSO.Sort = "Type ASC, Name ASC " 
    rsFSO.MoveFirst 

    'Populate the first column of the sheet 
    While Not rsFSO.EOF 
    name = rsFSO("Name").Value 
    If (name <> ThisWorkbook.name) Then 
     Cells(row, 1).Formula = name 
     row = row + 1 
    End If 
    rsFSO.MoveNext 
    Wend 

    'Close the recordset 
    rsFSO.Close 
    Set rsFSO = Nothing 

End Sub 

Private Sub TraverseFolderTree(ByVal parent As Object, ByVal node As Object, ByRef rs As Object) 

    'List all files 
    For Each file In node.Files 

    Dim name As String 
    name = Mid(file.Path, Len(parent.Path) + 2) 

    rs.AddNew 
    rs("Name") = name 
    rs("Type") = "FILE" 
    rs.Update 
    Next 

    'List all folders 
    For Each folder In node.SubFolders 
    TraverseFolderTree parent, folder, rs 
    Next 

End Sub 

即时回复将非常受欢迎，因为我的项目截止日期只有几个星期了。

谢谢！

Answer 1

你必须给file.Path添加到您的记录集，然后当你希望他们在您的循环链接尝试这样的事：

ActiveSheet.Hyperlinks.Add Anchor:=Cells(row, 1), Address:=file.Path, TextToDisplay:=name 

---

编辑

后rs.AddNew添加此行：

rs("Path") = file.Path 

再添加一个附加：

With rsFSO.Fields 
    .Append "Path", 200, 200 
    .Append "Name", 200, 200 
    .Append "Type", 200, 200 
End With 

现在改变你的这部分代码是这样的：

While Not rsFSO.EOF 
    name = rsFSO("Name").Value 
    path = rsFSO("Path").Value 
    If (name <> ThisWorkbook.name) Then 
     ActiveSheet.Hyperlinks.Add Anchor:=Cells(row, 1), Address:=path, TextToDisplay:=name 
     row = row + 1 
    End If 
    rsFSO.MoveNext 
    Wend 

您可能需要在你的代码是这样的顶部添加定义：

dim path as string