Sub ListLinks()
Dim xSheet As Worksheet
Dim xRg As Range
Dim xCell As Range
Dim xCount As Long
Dim xLinkArr() As String
On Error Resume Next
For Each xSheet In Worksheets
Set xRg = xSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
If xRg Is Nothing Then GoTo LblNext
For Each xCell In xRg
If InStr(1, xCell.Formula, "[") > 0 Then
xCount = xCount + 1
ReDim Preserve xLinkArr(1 To 6, 1 To xCount)
xLinkArr(1, xCount) = xCell.Address(, , , True)
xLinkArr(2, xCount) = "'" & xCell.Formula
'Chế lung tung đoạn này kekekekeke ---------------------------
xLinkArr(3, xCount) = xCell.Parent.Name & "!" & xCell.Address
xLinkArr(4, xCount) = Replace(Right(xCell.Formula, Len(xCell.Formula) - InStr(1, xCell.Formula, "]")), "'", "")
xLinkArr(5, xCount) = ""
xLinkArr(6, xCount) = Mid(xCell.Formula, InStr(1, xCell.Formula, "[") + 1, InStr(1, xCell.Formula, "]") - InStr(1, xCell.Formula, "[") - 1)
'Hết chế------------------------------------------------------
End If
Next
LblNext:
Next
If xCount > 0 Then
Sheets.Add(Sheets(1)).Name = "Link Sheet"
Range("A1").Resize(, 2).Value = Array("Location", "Reference")
Range("A2").Resize(UBound(xLinkArr, 2), UBound(xLinkArr, 1)).Value = Application.Transpose(xLinkArr)
Dim xlRange As Range
Set xlRange = ActiveSheet.Range("A2", Range("B" & Rows.Count).End(xlUp))
Dim Rng As Range
For Each Rng In xlRange
'Sửa linh tinh đoạn này kakakakaka------------------------------------
ActiveSheet.Hyperlinks.Add Anchor:=Rng, Address:=Rng.Offset(0, 4).Value, SubAddress:=Rng.Offset(0, 2).Value, TextToDisplay:=Rng.Value
'Hết sửa--------------------------------------------------------------
Next
Columns("A:F").AutoFit
Else
MsgBox "No links were found within the active workbook.", vbInformation, "KuTools for Excel"
End If
End Sub
