On Oct 10, 10:09*am, "KP" <none wrote:
Hi Don Guillett,

Thank you for your suggestion. I must say that this macro does exactly what
I was asking for. It works perfectly.
What is the purpose of "Sub FixIt()"
When do I have to run that?

Kaj Pedersen

"Don Guillett" skrev i en ...
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

It's just there in case the event codes stop working. You shouldn't
need it.