View Single Post
  #6   Report Post  
Posted to microsoft.public.excel.worksheet.functions
Gary Brown Gary Brown is offline
external usenet poster
 
Posts: 178
Default Active cell as a reference to open a worksheet

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
'/=========================================/