Active cell as a reference to open a worksheet
Gary
It is Bob's code but I'm sure he won't mind since we have given him initial
attribution.
I have copied your revised code. Thank you.
Gord
On Thu, 15 Mar 2007 06:26:00 -0700, Gary Brown
wrote:
Gordon,
I LOVED that code.
I've updated it for protected workbooks, calling the macro from a chart and
taking into account hidden worksheets. Hope you don't mind.
Sincerely,
Gary Brown
'/=========================================/
' Sub Purpose: a reference to open a worksheet
'From Discussion Group: Excel Worksheet Functions
'Date: 3/9/2007 2:53 PM PST
'From: Gord Dibben MS Excel MVP
'You could use code and a button you could place
'on a Toolbar so it is available for every sheet.
'Uses DIALOG SHEET.
'Here is macro from Bob Phillips that pops up a list of
' sheets to choose from.
'Revised by Gary Brown
'
Sub Worksheet_GoTo()
Const nPerColumn As Long = 30 'number of items per column
Const nWidth As Long = 8 'width of each letter
Const nHeight As Long = 18 'height of each row
Const kCaption As String = _
" Select sheet to goto" 'dialog caption
Const sID As String = "___SheetGoto" 'name of dialog sheet
Dim blnDisplayAlerts As Boolean
Dim blnScreenUpdating As Boolean
Dim thisDlg As DialogSheet
Dim i As Long
Dim iTopPos As Long
Dim iBooks As Long
Dim cCols As Long
Dim cLetters As Long
Dim cMaxLetters As Long
Dim cLeft As Long
Dim cb As OptionButton
Dim strCurrentWorkbook As String
Dim strCurrentWorksheet As String
Dim strDialogWkbk As String
Dim wksCurrentSheet As Worksheet
blnScreenUpdating = Application.ScreenUpdating
'check for an active workbook
If ActiveWorkbook Is Nothing Then 'no workbooks open, so create one
MsgBox "A Workbook is not open.", vbCritical + vbOKOnly, "Error..."
GoTo exit_Sub
End If
strCurrentWorkbook = Application.ActiveWorkbook.name
Application.ScreenUpdating = False
blnDisplayAlerts = Application.DisplayAlerts
' If ActiveWorkbook.ProtectStructure Then
' MsgBox "Workbook is protected.", vbCritical
' Exit Sub
' End If
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.DialogSheets(sID).Delete
Application.DisplayAlerts = True
On Error GoTo 0
If ActiveSheet.Type = -4167 Then
Set wksCurrentSheet = ActiveSheet
Else
Set wksCurrentSheet = Worksheets(1)
End If
If wksCurrentSheet Is Nothing Then
GoTo err_Sub
End If
strCurrentWorksheet = wksCurrentSheet.name
Workbooks.Add
strDialogWkbk = ActiveWorkbook.name
Set thisDlg = ActiveWorkbook.DialogSheets.Add
With thisDlg
.name = sID
'.Visible = xlSheetHidden
'sets variables for positioning on dialog
iBooks = 0
cCols = 0
cMaxLetters = 0
cLeft = 78
iTopPos = 40
Application.Workbooks(strCurrentWorkbook).Activate
For i = 1 To ActiveWorkbook.Worksheets.Count
If ActiveWorkbook.Worksheets(i).Visible = xlSheetVisible Then
If i Mod nPerColumn = 1 Then
cCols = cCols + 1
iTopPos = 40
cLeft = cLeft + (cMaxLetters * nWidth)
cMaxLetters = 0
End If
Set wksCurrentSheet = ActiveWorkbook.Worksheets(i)
cLetters = Len(wksCurrentSheet.name)
If cLetters cMaxLetters Then
cMaxLetters = cLetters
End If
iBooks = iBooks + 1
'.OptionButtons.Add cLeft, iTopPos, cLetters * nWidth, 16.5
.OptionButtons.Add cLeft, iTopPos, cLetters * nWidth, _
nHeight
.OptionButtons(iBooks).Text = _
ActiveWorkbook.Worksheets(i).name
If strCurrentWorksheet = .OptionButtons(iBooks).Text Then
.OptionButtons(iBooks).value = xlOn
End If
iTopPos = iTopPos + 13
End If
Next i
.Buttons.Left = cLeft + (cMaxLetters * nWidth) + 24
wksCurrentSheet.Activate
Application.Worksheets(strCurrentWorksheet).Activa te
With .DialogFrame
.Height = Application.Max(68, _
Application.Min(iBooks, nPerColumn) * nHeight + 10)
'.Height = Application.Min(iBooks, nPerColumn) * _
(nHeight - 4) + 10
.Width = cLeft + (cMaxLetters * nWidth) + 24
.Caption = kCaption
End With
.Buttons("Button 2").BringToFront
.Buttons("Button 3").BringToFront
Application.ScreenUpdating = True
If .Show Then
For Each cb In thisDlg.OptionButtons
If cb.value = xlOn Then
ActiveWorkbook.Worksheets(cb.Caption).Select
Exit For
End If
Next cb
Else
MsgBox "Nothing selected"
End If
Application.DisplayAlerts = False
' .Delete
End With
exit_Sub:
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Workbooks(strDialogWkbk).Activate
Set wksCurrentSheet = Nothing
Set thisDlg = Nothing
ActiveWindow.Close
Application.Workbooks(strCurrentWorkbook).Activate
Application.ScreenUpdating = blnScreenUpdating
Application.DisplayAlerts = blnDisplayAlerts
Exit Sub
err_Sub:
Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Sub: BrowseSheets - " & _
"Module: Mod_Worksheet_List - " & Now()
MsgBox "An error has occured." & vbCr & vbCr & _
"Error: " & Err.Number & " - " & Err.Description
GoTo exit_Sub
End Sub
'/=========================================/
|