Excel 将超链接添加到此VBA

下面的VBA允许用户选择文件夹，然后完整路径显示在激活图纸的第1列中

如何修改这些路径以使其作为超链接使用

Option Explicit
Sub cmdList()
    Dim sPath   As String
    Dim fOut    As Variant
    Dim r       As Integer
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select directory"
        .InitialFileName = ThisWorkbook.Path & "\"
        .AllowMultiSelect = False
        If .Show = 0 Then Exit Sub
        sPath = .SelectedItems(1)
    End With
    fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & sPath & """ /a:-h-s /b /s").StdOut.ReadAll, vbNewLine)
    r = 5
    Range(r & ":" & Rows.Count).Delete
   Cells(r, 1).Resize(UBound(fOut) + 1, 1).Value = WorksheetFunction.Transpose(fOut)
End Sub

---

谢谢

因为您的代码已经获得了完整的filespec，我们可以使用这些数据来完成

=HYPERLINK（）

公式：

Sub cmdList()
    Dim sPath   As String
    Dim fOut    As Variant
    Dim r       As Integer

    Dim Cell As Range

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select directory"
        .InitialFileName = ThisWorkbook.Path & "\"
        .AllowMultiSelect = False
        If .Show = 0 Then Exit Sub
        sPath = .SelectedItems(1)
    End With
    fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & sPath & """ /a:-h-s /b /s").StdOut.ReadAll, vbNewLine)
    r = 5
    Range(r & ":" & Rows.Count).Delete
   Cells(r, 1).Resize(UBound(fOut) + 1, 1).Value = WorksheetFunction.Transpose(fOut)

   '*************************************************************

   Dim dq As String,  rng As Range
   dq = Chr(34)

   Set Rng = Cells(r, 1).Resize(UBound(fOut) + 1, 1)
   For Each Cell In Rng
        Cell.Formula = "=HYPERLINK(" & dq & Cell.Value & dq & "," & dq & Cell.Value & dq & ")"
   Next Cell

End Sub

---

因为您的代码已经获得了完整的filespec，我们可以使用这些数据来完成

=HYPERLINK（）

公式：

Sub cmdList()
    Dim sPath   As String
    Dim fOut    As Variant
    Dim r       As Integer

    Dim Cell As Range

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select directory"
        .InitialFileName = ThisWorkbook.Path & "\"
        .AllowMultiSelect = False
        If .Show = 0 Then Exit Sub
        sPath = .SelectedItems(1)
    End With
    fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & sPath & """ /a:-h-s /b /s").StdOut.ReadAll, vbNewLine)
    r = 5
    Range(r & ":" & Rows.Count).Delete
   Cells(r, 1).Resize(UBound(fOut) + 1, 1).Value = WorksheetFunction.Transpose(fOut)

   '*************************************************************

   Dim dq As String,  rng As Range
   dq = Chr(34)

   Set Rng = Cells(r, 1).Resize(UBound(fOut) + 1, 1)
   For Each Cell In Rng
        Cell.Formula = "=HYPERLINK(" & dq & Cell.Value & dq & "," & dq & Cell.Value & dq & ")"
   Next Cell

End Sub

在“End sub”语法上方添加代码。以下代码将Activecell值更改为hyperlink

ActiveSheet.Hyperlinks.Add Activecell，Activecell.Value

我希望它对您有帮助。

在“End sub”语法上方添加代码。以下代码将Activecell值更改为hyperlink

ActiveSheet.Hyperlinks.Add Activecell，Activecell.Value

---

我希望这对你有帮助。

加里的学生，你是个好学徒！非常感谢。你是个好学徒，加里的学生！多谢。