List all sheets in the work book and select by double click

  • Thread starter Thread starter KP
  • Start date Start date
K

KP

Hi,

I need a macro to list all sheets in a workbook and be able to select from
the list by double clicking the name of the sheet.
(I am already aware of the possibility to right click the symbol left corner
in Excel).

The code below almost does the job, but I have to write the number
corresponding to the sheet and press enter.
Can somebody help with the code, so that I can double click the name.

Kaj Pedersen

myShts = ActiveWorkbook.Sheets.Count
For i = 1 To myShts
myList = myList & i & " - " & ActiveWorkbook.Sheets(i).Name & " " & vbCr
Next i
Dim mySht As Single
mySht = InputBox("Select sheet to go to." & vbCr & vbCr & myList)
Sheets(mySht).Select
 
In a standard module:

Option Explicit

Sub ListSheets()
Dim i As Integer
Load fGoToSheet
For i = 1 To ActiveWorkbook.Sheets.Count
fGoToSheet.ListBox1.AddItem Sheets(i).Name
Next 'i
fGoToSheet.Show
End Sub


In the code window behind a userform named "fGoToSheet":

Option Explicit

Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Sheets(ListBox1.List(ListBox1.ListIndex)).Activate
End Sub

...where CommandButton1's Caption is "OK". Note that the userform will
stay loaded until closed by the user. If you want it to close
automatically when the user double-clicks a sheetname then remove the
button and append its code to the ListBox1_DblClick event as follows...

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Sheets(ListBox1.List(ListBox1.ListIndex)).Activate: Unload Me
End Sub

If you want to have this added to the cells right-click popup menu then
it's a bit more involved, but doable.
 
I need a macro to list all sheets in a workbook and be able to select
from the list by double clicking the name of the sheet.

I know this isn't what you asked for, but perhaps this UserForm solution I
posted several years ago to an old newsgroup message might be of interest to
you.

Here is it, presented as I originally posted it (basically, it shows a
ListBox of all sheet names which you can click directly in (and get taken to
the clicked on tab name) or start to type the beginning text of a tab name
into a text box which will parse down the list of tab names so you can
either click or arrow down to make a selection). My previous post
follows....

Okay, here is something I think will meet your needs (don't be put off by
the its length, it is really worth the effort)... its a UserForm which lets
you type partial entries, pick from a list and takes you to the indicated
sheet. I'm going to assume you do not know how to implement a UserForm and
talk you through the whole process.

Go to the Visual Basic editor (press Alt+F11 from any worksheet). Once
there, click Insert/UserForm form the menu bar. You will see a blank form
and a window with the caption Toolbox. The Toolbox has controls (TextBox,
ListBox, etc.) on it that you will be placing on the blank UserForm (note..
the Toolbox is displayed only when the UserForm has focus). Before we put
any controls on the UserForm, let's rename it. On the left side of the VB
editor should be a window with the caption "Properties - UserForm1" (if you
don't see this, press F4). The first field of the Properties window is
labeled (Name) and next to it is the word UserForm1... click the word
UserForm1 and type GoToSheetSelector in its place. Next, look down and find
the Height and Width properties and set them to these values...

Height = 230
Width = 165

These, and other properties for the controls we will be putting on the
UserForm, are initial settings to get you started... you will be able to
modify them later to suit your own tastes. The rest of the default values
for the UserForm should be fine for now.

Okay, let's set the UserForm up. There will only be two controls on the
UserForm... a TextBox and a ListBox.

First, the TextBox. Give the UserForm focus (to make the Toolbox visible)
and click on the TextBox icon in the Toolbox (it is one with the lower case
letters "ab followed by a vertical bar) to place it. You can use the resize
handles to make the TextBox whatever size you want and you can click/drag it
to any position you want, but we will use the Properties window to set them
to exact values. There are only seven properties I want you to set
initially. In the Properties window, find and set the following values...

Height = 18
Left = 10
MultiLine = True
Top = 10
Width = 140
WordWrap = False

The seventh property is actually a dialog box for an object where you will
set 3 properties of the object. Click on the field to the right of the Font
property and you will see a little button with 3 dots in it... click that
button. On the dialog box that appears, set these properties....

Font = Arial
Font Style = Bold
Size = 10

Okay, that takes care of the TextBox. Next, let's add the ListBox. Click the
ListBox icon in the Toolbox (it is a rectangle with 3 horizontal lines on
the left and what are supposed to be up/down arrows on the right... if you
hover the mouse over the controls, a tooltip will appear with the control's
name... you are looking for ListBox) and then click/drag on the UserForm to
place it. Set the following properties for it in the Properties window...

Height = 165
Left = 10
Top = 38
Width = 140

Okay, that should take care of setting up the UserForm; now let's install
the code. Press F7 to bring up the code window for the UserForm (or simply
double click anywhere on the UserForm or one of its controls). Delete
anything you see in the code window that appears and copy/paste **all** of
the marked off code that follows my signature into this code window.

Okay, that takes care of the UserForm itself, now we just need a way to call
it up. Still in the VB editor, click Insert/Module from the menu bar.
Another code window will appear; copy/paste this into it...

Sub CallGoToSheetSelector()
GoToSheetSelector.Show
End Sub

Okay, that is pretty much it... the UserForm is usable right now. From any
sheet in your workbook, press Alt+F8, select CallGoToSheetSelector from the
list and click Run (we can do this differently and I'll explain how in a
moment). The UserForm will be displayed showing all sheets in your workbook
in the ListBox and the cursor will be in the TextBox. Here is how the
UserForm works. Start to type in the name of a sheet in your workbook and
the ListBox will show only sheet names starting with that text. You can
continue to type until only one name is left in the ListBox (you might not
have to type the full sheet name to completion for this to happen) and then
press the Return key to go to that sheet. But you don't have to keep typing
until there is only one sheet name left in the ListBox... at any time, you
can press either the down or right arrow and you will find yourself in the
ListBox itself where you can continue to use the arrow keys to place the
highlight on the sheet name you want, then press Return to go to that sheet.
If you find yourself in the TextBox by mistake, just press the left arrow
key to put yourself back into the TextBox. You can edit the text in the
TextBox and the ListBox will display the sheet names corresponding to the
type in text. If you type text that is not the starting text of a sheet
name, the ListBox will not display anything (if you mistype a letter so this
occurs, just delete the mistyped letter and the ListBox will adjust
accordingly). Oh, and you can also just click an entry in the ListBox with
your mouse and that will take you to the clicked on sheet name.

Okay, now about alternate methods of activating the UserForm (besides always
using Alt+F8/Select/Run). Go to any worksheet and press Alt+F8, select
CallGoToSheetSelector from the list and then click the Options button. This
will bring up a dialog box which lets you assign a shortcut key to your
macro. Type a lower case "g" in the indicated field, then click OK and close
the dialog box. Now, from any sheet in your workbook, press Ctrl+g and your
UserForm will appear, ready to use.

I think that is everything. If you have any questions, feel free to post
back.
 
I need a macro to list all sheets in a workbook and be able to select
from the list by double clicking the name of the sheet.

I know this isn't what you asked for, but perhaps this UserForm solution I
posted several years ago to an old newsgroup message might be of interest to
you.

Here is it, presented as I originally posted it (basically, it shows a
ListBox of all sheet names which you can click directly in (and get taken to
the clicked on tab name) or start to type the beginning text of a tab name
into a text box which will parse down the list of tab names so you can
either click or arrow down to make a selection). My previous post
follows....

Okay, here is something I think will meet your needs (don't be put off by
the its length, it is really worth the effort)... its a UserForm which lets
you type partial entries, pick from a list and takes you to the indicated
sheet. I'm going to assume you do not know how to implement a UserForm and
talk you through the whole process.

Go to the Visual Basic editor (press Alt+F11 from any worksheet). Once
there, click Insert/UserForm form the menu bar. You will see a blank form
and a window with the caption Toolbox. The Toolbox has controls (TextBox,
ListBox, etc.) on it that you will be placing on the blank UserForm (note..
the Toolbox is displayed only when the UserForm has focus). Before we put
any controls on the UserForm, let's rename it. On the left side of the VB
editor should be a window with the caption "Properties - UserForm1" (if you
don't see this, press F4). The first field of the Properties window is
labeled (Name) and next to it is the word UserForm1... click the word
UserForm1 and type GoToSheetSelector in its place. Next, look down and find
the Height and Width properties and set them to these values...

Height = 230
Width = 165

These, and other properties for the controls we will be putting on the
UserForm, are initial settings to get you started... you will be able to
modify them later to suit your own tastes. The rest of the default values
for the UserForm should be fine for now.

Okay, let's set the UserForm up. There will only be two controls on the
UserForm... a TextBox and a ListBox.

First, the TextBox. Give the UserForm focus (to make the Toolbox visible)
and click on the TextBox icon in the Toolbox (it is one with the lower case
letters "ab followed by a vertical bar) to place it. You can use the resize
handles to make the TextBox whatever size you want and you can click/drag it
to any position you want, but we will use the Properties window to set them
to exact values. There are only seven properties I want you to set
initially. In the Properties window, find and set the following values...

Height = 18
Left = 10
MultiLine = True
Top = 10
Width = 140
WordWrap = False

The seventh property is actually a dialog box for an object where you will
set 3 properties of the object. Click on the field to the right of the Font
property and you will see a little button with 3 dots in it... click that
button. On the dialog box that appears, set these properties....

Font = Arial
Font Style = Bold
Size = 10

Okay, that takes care of the TextBox. Next, let's add the ListBox. Click the
ListBox icon in the Toolbox (it is a rectangle with 3 horizontal lines on
the left and what are supposed to be up/down arrows on the right... if you
hover the mouse over the controls, a tooltip will appear with the control's
name... you are looking for ListBox) and then click/drag on the UserForm to
place it. Set the following properties for it in the Properties window...

Height = 165
Left = 10
Top = 38
Width = 140

Okay, that should take care of setting up the UserForm; now let's install
the code. Press F7 to bring up the code window for the UserForm (or simply
double click anywhere on the UserForm or one of its controls). Delete
anything you see in the code window that appears and copy/paste **all** of
the marked off code that follows my signature into this code window.

Okay, that takes care of the UserForm itself, now we just need a way to call
it up. Still in the VB editor, click Insert/Module from the menu bar.
Another code window will appear; copy/paste this into it...

Sub CallGoToSheetSelector()
GoToSheetSelector.Show
End Sub

Okay, that is pretty much it... the UserForm is usable right now. From any
sheet in your workbook, press Alt+F8, select CallGoToSheetSelector from the
list and click Run (we can do this differently and I'll explain how in a
moment). The UserForm will be displayed showing all sheets in your workbook
in the ListBox and the cursor will be in the TextBox. Here is how the
UserForm works. Start to type in the name of a sheet in your workbook and
the ListBox will show only sheet names starting with that text. You can
continue to type until only one name is left in the ListBox (you might not
have to type the full sheet name to completion for this to happen) and then
press the Return key to go to that sheet. But you don't have to keep typing
until there is only one sheet name left in the ListBox... at any time, you
can press either the down or right arrow and you will find yourself in the
ListBox itself where you can continue to use the arrow keys to place the
highlight on the sheet name you want, then press Return to go to that sheet.
If you find yourself in the TextBox by mistake, just press the left arrow
key to put yourself back into the TextBox. You can edit the text in the
TextBox and the ListBox will display the sheet names corresponding to the
type in text. If you type text that is not the starting text of a sheet
name, the ListBox will not display anything (if you mistype a letter so this
occurs, just delete the mistyped letter and the ListBox will adjust
accordingly). Oh, and you can also just click an entry in the ListBox with
your mouse and that will take you to the clicked on sheet name.

Okay, now about alternate methods of activating the UserForm (besides always
using Alt+F8/Select/Run). Go to any worksheet and press Alt+F8, select
CallGoToSheetSelector from the list and then click the Options button. This
will bring up a dialog box which lets you assign a shortcut key to your
macro. Type a lower case "g" in the indicated field, then click OK and close
the dialog box. Now, from any sheet in your workbook, press Ctrl+g and your
UserForm will appear, ready to use.

I think that is everything. If you have any questions, feel free to post
back.
 
Thanks to all of you.

I have never worked with User Forms before, so I will take a look of that
during the next couple of days. It seems as if it is a good solution.

If I don't succeed I think the Hyperlink method can be used.

Regards,
Kaj Pedersen
 
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(Before:=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
 
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(Before:=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
 
I have never worked with User Forms before, so I will take a look of
that during the next couple of days. It seems as if it is a good solution.

If you follow the instructions I give, you should have no trouble
implementing my solution. Unfortunately, I forgot to post the actual code
you are supposed to use with my earlier posting. So that you will have
everything altogether in one place, here is the complete posting
(instructions and code) that I should have posted in the first place (note
the code is at the end of the message). Sorry for any confusion I may have
caused. Oh, and one thing I wanted to point out about my suggested
solution... it automatically accounts for any changes you make to the
workbook... add or delete sheets or change sheet names, whatever, it
automatically lists the sheet structure that exists at the time you call it
up. Anyway, here is my suggested solution in its entirety...

Perhaps this UserForm solution I posted several years ago to an old
newsgroup message might work for you.

Here is it, presented as I originally posted it (basically, it shows a
ListBox of all sheets which you can click directly in (and get taken to the
clicked on tab name) or start to type the beginning text of a tab name into
a text box which will parse down the list of tab names so you can either
click or arrow down to make a selection). My previous post follows....

Okay, here is something I think will meet your needs (don't be put off by
the its length, it is really worth the effort)... its a UserForm which lets
you type partial entries, pick from a list and takes you to the indicated
sheet. I'm going to assume you do not know how to implement a UserForm and
talk you through the whole process.

Go to the Visual Basic editor (press Alt+F11 from any worksheet). Once
there, click Insert/UserForm form the menu bar. You will see a blank form
and a window with the caption Toolbox. The Toolbox has controls (TextBox,
ListBox, etc.) on it that you will be placing on the blank UserForm (note..
the Toolbox is displayed only when the UserForm has focus). Before we put
any controls on the UserForm, let's rename it. On the left side of the VB
editor should be a window with the caption "Properties - UserForm1" (if you
don't see this, press F4). The first field of the Properties window is
labeled (Name) and next to it is the word UserForm1... click the word
UserForm1 and type GoToSheetSelector in its place. Next, look down and find
the Height and Width properties and set them to these values...

Height = 230
Width = 165

These, and other properties for the controls we will be putting on the
UserForm, are initial settings to get you started... you will be able to
modify them later to suit your own tastes. The rest of the default values
for the UserForm should be fine for now.

Okay, let's set the UserForm up. There will only be two controls on the
UserForm... a TextBox and a ListBox.

First, the TextBox. Give the UserForm focus (to make the Toolbox visible)
and click on the TextBox icon in the Toolbox (it is one with the lower case
letters "ab followed by a vertical bar) to place it. You can use the resize
handles to make the TextBox whatever size you want and you can click/drag it
to any position you want, but we will use the Properties window to set them
to exact values. There are only seven properties I want you to set
initially. In the Properties window, find and set the following values...

Height = 18
Left = 10
MultiLine = True
Top = 10
Width = 140
WordWrap = False

The seventh property is actually a dialog box for an object where you will
set 3 properties of the object. Click on the field to the right of the Font
property and you will see a little button with 3 dots in it... click that
button. On the dialog box that appears, set these properties....

Font = Arial
Font Style = Bold
Size = 10

Okay, that takes care of the TextBox. Next, let's add the ListBox. Click the
ListBox icon in the Toolbox (it is a rectangle with 3 horizontal lines on
the left and what are supposed to be up/down arrows on the right... if you
hover the mouse over the controls, a tooltip will appear with the control's
name... you are looking for ListBox) and then click/drag on the UserForm to
place it. Set the following properties for it in the Properties window...

Height = 165
Left = 10
Top = 38
Width = 140

Okay, that should take care of setting up the UserForm; now let's install
the code. Press F7 to bring up the code window for the UserForm (or simply
double click anywhere on the UserForm or one of its controls). Delete
anything you see in the code window that appears and copy/paste **all** of
the marked off code that follows my signature into this code window.

Okay, that takes care of the UserForm itself, now we just need a way to call
it up. Still in the VB editor, click Insert/Module from the menu bar.
Another code window will appear; copy/paste this into it...

Sub CallGoToSheetSelector()
GoToSheetSelector.Show
End Sub

Okay, that is pretty much it... the UserForm is usable right now. From any
sheet in your workbook, press Alt+F8, select CallGoToSheetSelector from the
list and click Run (we can do this differently and I'll explain how in a
moment). The UserForm will be displayed showing all sheets in your workbook
in the ListBox and the cursor will be in the TextBox. Here is how the
UserForm works. Start to type in the name of a sheet in your workbook and
the ListBox will show only sheet names starting with that text. You can
continue to type until only one name is left in the ListBox (you might not
have to type the full sheet name to completion for this to happen) and then
press the Return key to go to that sheet. But you don't have to keep typing
until there is only one sheet name left in the ListBox... at any time, you
can press either the down or right arrow and you will find yourself in the
ListBox itself where you can continue to use the arrow keys to place the
highlight on the sheet name you want, then press Return to go to that sheet.
If you find yourself in the TextBox by mistake, just press the left arrow
key to put yourself back into the TextBox. You can edit the text in the
TextBox and the ListBox will display the sheet names corresponding to the
type in text. If you type text that is not the starting text of a sheet
name, the ListBox will not display anything (if you mistype a letter so this
occurs, just delete the mistyped letter and the ListBox will adjust
accordingly). Oh, and you can also just click an entry in the ListBox with
your mouse and that will take you to the clicked on sheet name.

Okay, now about alternate methods of activating the UserForm (besides always
using Alt+F8/Select/Run). Go to any worksheet and press Alt+F8, select
CallGoToSheetSelector from the list and then click the Options button. This
will bring up a dialog box which lets you assign a shortcut key to your
macro. Type a lower case "g" in the indicated field, then click OK and close
the dialog box. Now, from any sheet in your workbook, press Ctrl+g and your
UserForm will appear, ready to use.

I think that is everything. If you have any questions, feel free to post
back.

Rick Rothstein (MVP - Excel)

' *************** START OF CODE ***************
Dim SheetNames() As String

Private Sub UserForm_Initialize()
Dim Obj As Object
TextBox1.Text = ""
TextBox1.EnterKeyBehavior = True
ReDim SheetNames(0 To Sheets.Count - 1)
For Each Obj In Sheets
SheetNames(Obj.Index - 1) = Obj.Name
ListBox1.AddItem Obj.Name
Next
TextBox1.SetFocus
End Sub

Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
With TextBox1
If KeyCode = vbKeyLeft Then
ListBox1.ListIndex = -1
.SelStart = Len(.Text)
.SetFocus
ElseIf KeyCode = vbKeyReturn Then
If ListBox1.ListCount > 0 Then
Sheets(ListBox1.Text).Activate
Unload Me
End If
End If
End With
End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As _
Integer, ByVal X As Single, ByVal Y As Single)
Sheets(ListBox1.List(ListBox1.ListIndex)).Activate
Unload Me
End Sub

Private Sub TextBox1_Change()
Dim X As Long
Dim Pages() As String
Pages = Filter(SheetNames, TextBox1.Text, True, vbTextCompare)
If Len(TextBox1.Text) Then
If UBound(Pages) > -1 Then
With ListBox1
.Clear
For X = 0 To UBound(Pages)
.AddItem Mid$(Pages(X), 1)
Next
End With
Else
ListBox1.Clear
End If
Else
ListBox1.Clear
For X = 0 To UBound(SheetNames)
ListBox1.AddItem Mid$(SheetNames(X), 2)
Next
End If
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
With ListBox1
If KeyCode = vbKeyReturn Then
KeyCode = 0
If .ListCount = 0 Then
Exit Sub
ElseIf .ListCount = 1 Then
Sheets(.List(0)).Activate
Unload Me
Else
.SetFocus
.Selected(0) = True
.ListIndex = 0
End If
ElseIf (KeyCode = vbKeyDown Or (KeyCode = vbKeyRight And _
TextBox1.SelStart = Len(TextBox1.Text))) And .ListCount > 0 Then
.SetFocus
.Selected(0) = True
.ListIndex = 0
End If
End With
End Sub
' *************** END OF CODE ***************
 
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" <[email protected]> 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(Before:=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
 
Damn! All I posted were the instructions... I forgot to include the code in
my posting. Here is that code...

' *************** START OF USERFORM CODE ***************
Private Sub UserForm_Initialize()
Dim Obj As Object
TextBox1.Text = ""
TextBox1.EnterKeyBehavior = True
For Each Obj In Sheets
If Obj.Visible Then ListBox1.AddItem Obj.Name
Next
TextBox1.SetFocus
End Sub

Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
With TextBox1
If KeyCode = vbKeyLeft Then
ListBox1.ListIndex = -1
.SelStart = Len(.Text)
.SetFocus
ElseIf KeyCode = vbKeyReturn Then
If ListBox1.ListCount > 0 Then
Sheets(ListBox1.Text).Activate
Unload Me
End If
End If
End With
End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Sheets(ListBox1.List(ListBox1.ListIndex)).Activate
Unload Me
End Sub

Private Sub TextBox1_Change()
Dim X As Long
ListBox1.Clear
For X = 1 To Sheets.Count
If InStr(1, Sheets(X).Name, TextBox1.Text, vbTextCompare) = 1 And _
Sheets(X).Visible Then ListBox1.AddItem Sheets(X).Name
Next
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
With ListBox1
If KeyCode = vbKeyReturn Then
KeyCode = 0
If .ListCount = 0 Then
Exit Sub
ElseIf .ListCount = 1 Then
Sheets(.List(0)).Activate
Unload Me
Else
.SetFocus
.Selected(0) = True
.ListIndex = 0
End If
ElseIf (KeyCode = vbKeyDown Or (KeyCode = vbKeyRight And _
TextBox1.SelStart = Len(TextBox1.Text))) And .ListCount > 0 Then
.SetFocus
.Selected(0) = True
.ListIndex = 0
End If
End With
End Sub
' *************** END OF CODE ***************
 
Damn! All I posted were the instructions... I forgot to include the code in
my posting. Here is that code...

' *************** START OF USERFORM CODE ***************
Private Sub UserForm_Initialize()
Dim Obj As Object
TextBox1.Text = ""
TextBox1.EnterKeyBehavior = True
For Each Obj In Sheets
If Obj.Visible Then ListBox1.AddItem Obj.Name
Next
TextBox1.SetFocus
End Sub

Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
With TextBox1
If KeyCode = vbKeyLeft Then
ListBox1.ListIndex = -1
.SelStart = Len(.Text)
.SetFocus
ElseIf KeyCode = vbKeyReturn Then
If ListBox1.ListCount > 0 Then
Sheets(ListBox1.Text).Activate
Unload Me
End If
End If
End With
End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Sheets(ListBox1.List(ListBox1.ListIndex)).Activate
Unload Me
End Sub

Private Sub TextBox1_Change()
Dim X As Long
ListBox1.Clear
For X = 1 To Sheets.Count
If InStr(1, Sheets(X).Name, TextBox1.Text, vbTextCompare) = 1 And _
Sheets(X).Visible Then ListBox1.AddItem Sheets(X).Name
Next
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
With ListBox1
If KeyCode = vbKeyReturn Then
KeyCode = 0
If .ListCount = 0 Then
Exit Sub
ElseIf .ListCount = 1 Then
Sheets(.List(0)).Activate
Unload Me
Else
.SetFocus
.Selected(0) = True
.ListIndex = 0
End If
ElseIf (KeyCode = vbKeyDown Or (KeyCode = vbKeyRight And _
TextBox1.SelStart = Len(TextBox1.Text))) And .ListCount > 0 Then
.SetFocus
.Selected(0) = True
.ListIndex = 0
End If
End With
End Sub
' *************** END OF CODE ***************
 
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" <[email protected]> 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(Before:=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.
 
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" <[email protected]> skrev i en meddelelseOn Oct 10, 2:21 am, minimaster <[email protected]>
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(Before:=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.
 
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 said:
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(Before:=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
 
Hi minimaster,

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 said:
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(Before:=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
 
Hi minimaster

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 said:
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(Before:=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
 
Hi Rick,

I am glad that you introduced me to UserForms and I must say that your
instructions were very understandable and easy to follow.
I succeeded in setting it all up, so that I can call the window showing all
my sheets.
I think this is the method I prefer to implement.
Thanks again.

Best regards,
Kaj Pedersen
 
I am glad that you introduced me to UserForms and I must say
that your instructions were very understandable and easy to follow.
I succeeded in setting it all up, so that I can call the window showing
all my sheets.
I think this is the method I prefer to implement.
Thanks again.

You are quite welcome. If you think you will want to use this idea on other
projects, you may want to do what I did... install the code on a clean
workbook (or just take the one you have and delete all data and any VB code
(other than the code I gave you of course) and then save the workbook as an
Excel Template. That way, whenever you start a new workbook, just pick that
template instead of a blank workbook and the functionality will be
immediately available. If this is a new concept to you, write back with your
Excel version number and I'll try to provide instructions to you for that
version.

Rick Rothstein (MVP - Excel)
 
Hi KP,

If you have problems with sheets that have numbers then you might have
had problems copying the code properly from my posting. In the code
there is a line

c(i, 2).Value = "'" & Sheets(i).Name

The single quote in front of the sheet name is important so sheet
names that are numbers are correctly recognized as text when listing
them for hyperlink purposes.

Regarding the error at line .Autosize = True I need more information.
I need to know your Excel version and the error message.
May be this be a code copy and paste problem too ?

This board intro's line breaks which are not there in the real code.
These extra line feeds must be removed when doing a copy and paste
from this forum.
 
Hi minimaster,

I was fully aware of the line breaks, so this was not the problem.
Also the line: c(i, 2).Value = "'" & Sheets(i).Name was correct.
I found out that for some reason one of the "Back" bottons was not removed
when running "Delete QuickLinks"
As soon as i deleted this sheet the problem was fixed.

Now sheets named by number and everything else are showed as QuickLinks and
I must say that the "Back" button is a nice feature.
Thank you for your help in this case.

Regards,
Kaj Pedersen
 
Back
Top