Phần màu xanh là phần code tự tạo: 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
Nhận xét
Đăng nhận xét