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