Добавить гиперссылки на этот VBA

Question

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

Спасибо!

Answer 1

добавить код над синтаксисом «End sub».Следующий код изменит значение Activecell на гиперссылку

ActiveSheet.Hyperlinks.Add Activecell, Activecell.Value

Надеюсь, это полезно для вас.

Answer 2

Поскольку ваш код уже получает полную спецификацию файла, мы можем использовать данные для заполнения формул =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