EXCEL VBA INDEX: Tự động tạo Menu Hyperlink cho tất cả file trong thư mục

Sub này sẽ giúp scan thư mục hiện hành, liệt kê chi tiết: Tên File - Tên từng Sheet - Đường dẫn mở nhanh (Hyperlink).

 template

Sub hypelinkcurrentfolder()

   Application.ScreenUpdating = False

     Application.DisplayAlerts = False

warning = MsgBox("Ban co muon chay macro nay?", vbYesNo, "Canh bao")

If warning = vbYes Then

    Dim FolderPath As String

    Dim fileName As String

    Dim wb As Workbook

    Dim ws As Worksheet

    Dim lastRow As Long

       FolderPath = ThisWorkbook.Path & "\"

     ThisWorkbook.Sheets(1).Range("C3:e100000").ClearContents

     fileName = Dir(FolderPath & "*.xls*")

    Do While fileName <> ""

               If fileName <> ThisWorkbook.Name Then

                      Set wb = Workbooks.Open(FolderPath & fileName)

                      For Each ws In wb.Worksheets

                             lastRow = ThisWorkbook.Sheets(1).Cells(Rows.Count, "c").End(xlUp).Row

                              ThisWorkbook.Sheets(1).Cells(lastRow + 1, "c").Value = wb.Name

                              ThisWorkbook.Sheets(1).Cells(lastRow + 1, "d").Value = ws.Name

                               Dim hyperlinkAddress As String

                hyperlinkAddress = wb.Name & "#'" & ws.Name & "!A1"

                              ThisWorkbook.Sheets(1).Hyperlinks.Add _

                    Anchor:=ThisWorkbook.Sheets(1).Cells(lastRow + 1, "e"), _

                    Address:="", _

                    SubAddress:="'" & ws.Name & "'!A1", _

                    TextToDisplay:="Open file"

       ThisWorkbook.Sheets(1).Hyperlinks(ThisWorkbook.Sheets(1).Hyperlinks.Count).Address = hyperlinkAddress

            Next ws

                      wb.Close SaveChanges:=False

        End If

             fileName = Dir()

    Loop

      End If

     Application.ScreenUpdating = True

     Application.DisplayAlerts = True

  

End Sub