Hi,

I have tried your code and it works but there are some problems:
If the name of the sheet is a number or the name of the sheet has many
characters the macro fails.

---------------------------------------------
Sub Add_BackButton(r As object)

..AutoSize = True (Macro stops and this text turns yellow)
I have tried to set it to False without success.

Does someone has a solution to this.

Regards,
Kaj Pedersen




"minimaster" skrev i en meddelelse
...
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