Option Explicit
Sub tao_lien_ket()
Dim lastRow As Long, r As Long, hl As Hyperlink, cell_ As Range, rng As Range, ten As String
For Each hl In Sheet2.Hyperlinks ' loai bo tat ca cac Hyperlik trong cot B cua sheet2
If hl.Range.Column = 2 Then hl.Delete
Next hl
With Sheet2 ' Sheet2 la sheet "Muc luc"
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
If lastRow < 2 Then Exit Sub
For r = 2 To lastRow
If .Range("B" & r).Value <> "" Then
Set cell_ = Sheet1.Range("B2:B10000").Find(.Range("B" & r).Value, , xlValues, xlWhole, xlByRows, xlNext) ' sheet1 la sheet "Danh sach"
If Not cell_ Is Nothing Then
On Error Resume Next
ten = Replace(.Range("B" & r).Value, " ", "_")
Set rng = Sheet1.Range(ten)
If Not rng Is cell_ Then ThisWorkbook.Names.Add Name:=ten, RefersTo:="='" & cell_.Parent.Name & "'!" & cell_.Address
On Error GoTo 0
.Hyperlinks.Add Anchor:=.Range("B" & r), Address:="", SubAddress:=ten, TextToDisplay:=.Range("B" & r).Value
Set rng = Nothing
End If
End If
Next r
End With
End Sub
!
