Sub TablesContent()
Dim iTbl As ListObject
Dim iList As String
Application.ScreenUpdating = False
On Error Resume Next
ActiveSheet.Columns(1).ClearContents
For Each iTbl In ActiveSheet.ListObjects
    iTbl.Name = iTbl.Range(1).Offset(-1).Value
    If iList <> Empty Then
        iList = iList & ";" & iTbl.Name
    Else
        iList = iTbl.Name
    End If
    With ActiveSheet
        .Hyperlinks.Add Anchor:=.Range("A" & I + 2), Address:="", SubAddress:=iTbl.Range(1).Offset(-1).Address, TextToDisplay:=iTbl.Name
    End With
    I = I + 1
Next
With ActiveSheet.Range("A1")
    With .Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=iList
    End With
    .Value = Split(iList, ";")(0)
End With
Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing And Target.Count = 1 Then
    Call AGoto(Target)
End If
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Call AGoto(Target.Parent)
    Application.EnableEvents = False
        Range("A1") = Target.TextToDisplay
    Application.EnableEvents = True
End Sub

Private Sub AGoto(rng As Range)
Dim iTbl As Range
Dim cl As Range
Dim iHLinks As Range
    Application.ScreenUpdating = False
    On Error Resume Next
    Set iTbl = Me.ListObjects(rng.Value).HeaderRowRange(1).Offset(-1)
    For Each cl In Intersect(Me.UsedRange, Columns(1)).Cells
        If cl.Hyperlinks.Count Then
            If Not iHLinks Is Nothing Then
                Set iHLinks = Union(iHLinks, cl)
            Else
                Set iHLinks = cl
            End If
        End If
    Next
    If Not iHLinks Is Nothing Then
        Application.EnableEvents = False
        iHLinks.Cut iTbl.Offset(, -1)
        Application.EnableEvents = True
    End If
    Application.Goto iTbl, True
    iTbl.Select
    Application.ScreenUpdating = True
End Sub