Sub Sheet_lister() 
    Dim ceLL As Range 
    Dim i As Long 
    Dim Button1 As Object 
    Dim Button2 As Object 
    Dim Ws1 As Worksheet 
    Dim Ws2 As Worksheet 
    Dim Exist As Boolean 
     
    Application.ScreenUpdating = False 
     
    For Each Ws1 In Worksheets 
        If Ws1.Name Like "Sheet List" Then Exist = True: Exit For 
    Next 
    If Exist = True Then 
        With Sheets("Sheet List") 
            .Activate 
            .Columns(1).Clear 
        End With 
    Else 
        Sheets.Add before:=Worksheets(1) 
        ActiveSheet.Name = "Sheet List" 
         
        With Range("A1") 
            Set Button2 = ActiveSheet.Buttons.Add(Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height) 
        End With 
         
        With Button2 
            .Name = "Button2" 
            .OnAction = "Sheet_lister" 
            .Characters.Text = "Make list" 
            .Characters.Font.Name = "Arial" 
            .Characters.Font.Size = 11 
            .Characters.Font.Color = vbRed 
             '.Characters.Font.Bold = True
        End With 
         
    End If 
     
     
    For i = 2 To Sheets.Count 
        Cells(i + 1, 1) = Sheets(i).Name 
        Columns(1).AutoFit 
         
        If Columns(1).ColumnWidth < 18 Then 
            Columns(1).ColumnWidth = 18 
        End If 
         
        Cells(i + 1, 1).NumberFormat = "@* " 
    Next i 
     
     
    For Each ceLL In Range("A3", Range("A3").End(xlDown)) 
        ceLL.Hyperlinks.Add Anchor:=ceLL, Address:="", _ 
        SubAddress:="'" & Replace(ceLL.Value, "'", "''") & "'" & "!a1", ScreenTip:="Click to move to sheet", TextToDisplay:=ceLL.Value 
    Next 
     
    Range("A3:A" & Cells(Rows.Count, "A").End(xlUp).Row).Font.Underline = xlUnderlineStyleNone 
     
     
    Application.ScreenUpdating = True 
    Sheets("Sheet List").Activate 
End Sub 
 
Sub Back() 
    Sheets("Sheet List").Activate 
End Sub