About Us

Don Guillett[_2_]

On Oct 10, 11:52*am, Don Guillett wrote:
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.

Thread Tools	Search this Thread
Show Printable Version	Search this Thread: Advanced Search
Display Modes
Switch to Linear Mode Switch to Hybrid Mode Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Formula in Excel does not work until after I double-click inside c	raaaabert	Excel Discussion (Misc queries)	7	June 8th 17 02:01 PM
Mouse double-click to select listbox item and run userform	Lemi	Excel Programming	3	July 19th 09 03:01 PM
Function does not work unless I double click the cell and push ent	just me	Excel Discussion (Misc queries)	4	March 14th 07 06:32 PM
Double click xlsname in explorer doesn't work.	Lew Schwartz	New Users to Excel	2	October 11th 06 02:33 PM
Double Click for all Sheets	Marvin	Excel Programming	4	March 17th 05 03:49 PM

Menu

About Us