向此 VBA 添加超链接答案

【问题标题】：Add Hyperlinks to this VBA向此 VBA 添加超链接
【发布时间】：2019-03-30 13:31:53
【问题描述】：

下面的 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

谢谢！

【问题讨论】：

标签： excel vba hyperlink directory

【解决方案1】：

因为您的代码已经获得了完整的文件规范，我们可以使用这些数据来完成=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

【讨论】：

你是一个优秀的学徒，加里的学生！非常感谢。

【解决方案2】：

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

ActiveSheet.Hyperlinks.Add Activecell、Activecell.Value

希望对你有帮助。

【讨论】：