Sub 创建目录()
    Dim sht As Worksheet
    If Not ShtExists("目录") Then
        Set sht = Sheets.Add(before:=Sheets(1))
        sht.Name = "目录"
    Else
        Set sht = Sheets("目录")
    End If
    sht.[A1] = "序号"
    sht.[B1] = "目录"
    sht.[2:10000].ClearContents
    For i = 2 To Sheets.Count
        sht.Cells(i, 1) = i - 1
        sht.Cells(i, 2) = Sheets(i).Name
        '主表添加超链接
        sht.Hyperlinks.Add Anchor:=sht.Cells(i, 2), Address:="", SubAddress:= _
                "'" & Sheets(i).Name & "'!A1", TextToDisplay:=Sheets(i).Name
        '子表添加返回超链接
        Sheets(i).Hyperlinks.Add Anchor:=Sheets(i).Range("I1"), Address:="", SubAddress:= _
                "目录!B" & i, TextToDisplay:="返回目录"
    Next
End Sub

Function ShtExists(shtname)
    '判断Sheet表是否存在
    On Error Resume Next
    Dim s
    Err.Clear
    s = Sheets(shtname & "").Name
    If Err.Number = 0 Then
        ShtExists = True
    Else
        ShtExists = False
    End If
End Function