On Oct 10, 2:21*am, minimaster
wrote:
Hi KP
I have some old code which does what your asking for with one
exception, instead of double clicks it puts hyperlinks onto the sheet
name for jumping to the sheet. An additional nice feature is the
addition of a little shape in each sheet that allows you to jump back.
Plus there are routines to remove it all automatically.

To be put into a std module:
'---------------------------------------------------
Sub Create_Quicklinks()

* * Dim ls As Worksheet
* * Dim c As Range
* * Dim i As Integer
* * Set ls = Worksheets.Add(Befo=Sheets(1))
* * On Error GoTo delete_old_sheet:
* * ls.Name = "Quicklinks"

* * On Error GoTo 0
* * Set c = ls.[A1]
* * c(1, 1).Value = "#"
* * c(1, 2).Value = "Worksheet"
* * For i = 2 To Sheets.Count
* * * * c(i, 1).Value = i
* * * * c(i, 2).Value = "'" & Sheets(i).Name
* * * * If Sheets(i).Visible = xlSheetVisible Then
* * * * * * ls.Hyperlinks.Add Anchor:=c(i, 2), Address:="",
SubAddress:="'" & Sheets(i).Name & "'!A1", TextToDisplay:=c(i,
2).Value
* * * * * * Call Add_BackButton(Sheets(i))
* * * * Else
* * * * * * c(i, 2).Value = "HIDDEN: " & c(i, 2).Value
* * * * End If
* * Next i
* * With Range("A1:B1")
* * * * .Interior.ColorIndex = 23
* * * * .Font.Bold = True
* * * * .Font.ColorIndex = 2
* * End With
* * With ls.Columns("A:A")
* * * * .ColumnWidth = 3.3
* * * * .HorizontalAlignment = xlCenter
* * End With
* * ls.Columns("B:B").EntireColumn.AutoFit
* * Exit Sub
delete_old_sheet:
* * Call DeleteQuicklinks
* * Resume
End Sub
'-------------------------------------------------------
Sub DeleteQuicklinks()

* * Application.DisplayAlerts = False
* * Worksheets("Quicklinks").Delete
* * Call delete_Back_Shapes
* * Application.DisplayAlerts = True

End Sub
'--------------------------------------------------------
Sub Add_BackButton(r As Object)

* * Dim shp As Shape
* * If r.Type = xlWorksheet Then
* * * * Set shp = r.Shapes.AddShape(Type:=msoShapeLeftArrow,
Left:=r.Range("A1").Left + 5, Top:=r.Range("A1").Top + 7, Width:=30,
Height:=25)
* * Else
* * * * Set shp = r.Shapes.AddShape(Type:=msoShapeLeftArrow,
Left:=r.ChartArea.Left + 5, Top:=r.ChartArea.Top + 7, Width:=30,
Height:=25)
* * End If
* * With shp
* * * * With .TextFrame.Characters
* * * * * * .Text = "Back"
* * * * * * .Font.ColorIndex = 2
* * * * * * .Font.Bold = True
* * * * * * .Font.Size = 10
* * * * End With
* * * * With .TextFrame
* * * * * * .AutoSize = True
* * * * * * .MarginBottom = 0
* * * * * * .MarginLeft = 0
* * * * * * .MarginRight = 2
* * * * * * .MarginTop = 0
* * * * End With
* * * * .Line.Visible = msoFalse
* * * * .Fill.ForeColor.RGB = RGB(128, 128, 128)
* * * * .Fill.Transparency = 0.7
* * * * .Placement = xlFreeFloating
* * * * .ControlFormat.PrintObject = False
* * End With

* * r.Hyperlinks.Add Anchor:=shp, Address:="",
SubAddress:="'Quicklinks'!A1", ScreenTip:="Back to Quicklinks"

End Sub
'-----------------------------------------------------
Sub delete_Back_Shapes()
* * Dim ws As Worksheet
* * Dim shp As Shape
* * For Each ws In Worksheets
* * * * For Each shp In ws.Shapes
* * * * * * If shp.Type = 1 Then
* * * * * * * * If shp.TextFrame.Characters.Text = "Back" Then
* * * * * * * * * * shp.Delete
* * * * * * * * End If
* * * * * * End If
* * * * Next shp
* * Next ws
* * On Error GoTo 0
End Sub

Put this macro in the sheet module to make a list of the sheets and
then double click the cell
Option Explicit
Sub listsheets()
Dim i As Long
Columns(1).Clear
For i = 1 To Sheets.Count
Cells(i, 1).Value = Sheets(i).Name
Next i
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel
As Boolean)
Dim WantedSheet As String
WantedSheet = Trim(ActiveCell.Value)
If WantedSheet = "" Then Exit Sub
On Error Resume Next
If Not Sheets(WantedSheet) Is Nothing Then
Application.Goto Sheets(WantedSheet).Range("a1")
End If
End Sub

Sub FixIt()
Application.EnableEvents = True
End Sub