Tạo hyperlink cho danh sách tên thư mục

[Yugitran]

Chào các anh chị,
Mình có đoạn code lấy danh sách tên các thư mục. Mình mong muốn sau khi lấy tên thư mục thì tạo hyperlink cho các tên thư mục vừa lấy được.
Nhờ mọi người giúp đỡ. Cảm ơn mọi người rất nhiều.

 

[giaiphap]

Chào các anh chị,
Mình có đoạn code lấy danh sách tên các thư mục. Mình mong muốn sau khi lấy tên thư mục thì tạo hyperlink cho các tên thư mục vừa lấy được.
Nhờ mọi người giúp đỡ. Cảm ơn mọi người rất nhiều.

Sửa code Sub ListFoldersInDirectory lại thế này

Sub ListFoldersInDirectory()


    Dim objFSO As Object
    Dim objFolders As Object
    Dim objFolder As Object
    Dim strDirectory As String
    Dim arrFolders() As String
    Dim FolderCount As Long
    Dim FolderIndex As Long
    Dim sCell As Range

    Range("A5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Select Folder"
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        End If
        strDirectory = .SelectedItems(1)
    End With
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolders = objFSO.GetFolder(strDirectory).SubFolders
    
    FolderCount = objFolders.Count
    
    If FolderCount > 0 Then
        ReDim arrFolders(1 To FolderCount)
        FolderIndex = 0
        For Each objFolder In objFolders
            FolderIndex = FolderIndex + 1
            arrFolders(FolderIndex) = objFolder.Name
        Next objFolder
       ' Worksheets.Add
        With Sheets(1)
            .Range("A5").Resize(FolderCount).Value = Application.Transpose(arrFolders)
            For Each sCell In .Range("A5").Resize(FolderCount)
                .Hyperlinks.Add Anchor:=sCell, Address:=sCell.Value2, TextToDisplay:=sCell.Value2
            Next sCell
        End With
    Else
        MsgBox "No folders found!", vbExclamation
    End If
    
    Set objFSO = Nothing
    Set objFolders = Nothing
    Set objFolder = Nothing
    
    
End Sub

 

[Yugitran]

Sửa code Sub ListFoldersInDirectory lại thế này

Sub ListFoldersInDirectory()


    Dim objFSO As Object
    Dim objFolders As Object
    Dim objFolder As Object
    Dim strDirectory As String
    Dim arrFolders() As String
    Dim FolderCount As Long
    Dim FolderIndex As Long
    Dim sCell As Range

    Range("A5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Select Folder"
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        End If
        strDirectory = .SelectedItems(1)
    End With
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolders = objFSO.GetFolder(strDirectory).SubFolders
   
    FolderCount = objFolders.Count
   
    If FolderCount > 0 Then
        ReDim arrFolders(1 To FolderCount)
        FolderIndex = 0
        For Each objFolder In objFolders
            FolderIndex = FolderIndex + 1
            arrFolders(FolderIndex) = objFolder.Name
        Next objFolder
       ' Worksheets.Add
        With Sheets(1)
            .Range("A5").Resize(FolderCount).Value = Application.Transpose(arrFolders)
            For Each sCell In .Range("A5").Resize(FolderCount)
                .Hyperlinks.Add Anchor:=sCell, Address:=sCell.Value2, TextToDisplay:=sCell.Value2
            Next sCell
        End With
    Else
        MsgBox "No folders found!", vbExclamation
    End If
   
    Set objFSO = Nothing
    Set objFolders = Nothing
    Set objFolder = Nothing
   
   
End Sub

Cảm ơn bạn rất nhiều.
Code này lấy được hyperlink cho các thư mục con có trong thư mục đang chứa file này. Khi mình lưu file ở đường dẫn khác thì không lấy hyperlink được. Nhờ bạn nghiên cứu thêm giúp mình.