Back to Index Button - vba

Question

I have an excel file with 208 sheets and a summary sheet. Want to create a button to jump to each sheet. i am using the below codes for that.
Sub SearchSheetName()
Dim xName As String
Dim xFound As Boolean
xName = InputBox("Enter sheet name to find in workbook:", "Sheet search")
If xName = "" Then Exit Sub
On Error Resume Next
ActiveWorkbook.Sheets(xName).Select
xFound = (Err = 0)
On Error GoTo 0
If xFound Then
MsgBox "Sheet '" & xName & "' has been found and selected!"
Else
MsgBox "The sheet '" & xName & "' could not be found in this workbook!"
End If
End Sub
Going back to Summary sheet is difficult. so created macro with button
Private Sub CommandButton1_Click()
Sheets("SummarySheet").Select
End Sub
is there any easy way to create this button in all the sheets together.

Answer 1

I will add a button or shape (they are more pleasing in terms of cosmetics) to the sheet dynamically when its activated. Use Workbook's SheetActivate event to apply this to all the worksheets in the workbook.
In the WorkBook's SheetActivate add this
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Call addButton
End Sub
VBA code in a standard module:
Sub addButton()
'/ Dynamically add a semi-transparent shape on the active sheet.
'/ Call this inside workbooks SheetActivate event
Dim shp As Shape
Const strButtonName As String = "BackButton"
'/ Dont't add on summary sheet.
If ActiveSheet.Name = "Summary" Then Exit Sub
Application.ScreenUpdating = False
'/ Delete if old shape exists
For Each shp In ActiveSheet.Shapes
If shp.Name = strButtonName Then
shp.Delete
End If
Next
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 330.75, 36.75, 93.75, 29.25).Select
Selection.Name = "BackButton"
Set shp = ActiveSheet.Shapes(strButtonName)
'/ Some formatting for the shape.
With shp
.TextFrame.Characters.Text = "Summary"
.Top = 3
.Left = 3
.Fill.Transparency = 0.6
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 112, 192)
.TextFrame2.VerticalAnchor = msoAnchorMiddle
'/ Add the macro to shape's click. This will active summary sheet.
shp.OnAction = "goBack"
End With
ActiveSheet.Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
Sub goBack()
ThisWorkbook.Worksheets("Summary").Select
End Sub

Answer 2

This sounds like a Table of Contents (TOC) question. Copy/paste the code below and see if it does essentially what you want.
Option Explicit
Sub Macro1()
Dim i As Integer
Dim TOC As String
Dim msg As String
Dim fc_order As Range
Dim fc_alphabet As Range
Dim sht As Object
TOC = "Table of Contents"
For i = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(i).Name = TOC Then
msg = Chr(10) & Chr(10) & "Your sheet " & Chr(10) & TOC & Chr(10) & "(now displayed) will be updated."
Worksheets(TOC).Activate
Exit For
Else
msg = "A new sheet will be added :" & TOC & ", with hyperlinks to all sheets in this workbook."
End If
Next i
If MsgBox(msg & Chr(10) & "Do you want to continue ?", 36, TOC) = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If ActiveSheet.Name = TOC Then Worksheets(TOC).Delete
Worksheets(1).Activate
Worksheets.Add.Name = TOC
Cells.Interior.ColorIndex = 15
ActiveWindow.DisplayHeadings = False
With Cells(2, 6)
.Value = UCase(TOC)
.Font.Size = 18
.HorizontalAlignment = xlCenter 'verspreid over blad breedte
End With
Set fc_order = Cells(3, 4)
Set fc_alphabet = Cells(3, 8)
fc_order = "order of appearance"
For i = 2 To ActiveWorkbook.Worksheets.Count
If i Mod 30 = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=fc_order.Offset(i - 1, -2), Address:="", _
SubAddress:="'" & Worksheets(TOC).Name & "'!A1", TextToDisplay:="TOP"
End If
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 2, 4), Address:="", _
SubAddress:=Worksheets(i).Name & "!A1", TextToDisplay:=Worksheets(i).Name
Next i
fc_alphabet = "alphabetically"
Range(fc_order.Offset(1, 0), fc_order.End(xlDown)).Copy fc_alphabet.Offset(1, 0)
Range(fc_alphabet.Offset(1, 0), fc_alphabet.End(xlDown)).Sort Key1:=fc_alphabet.Offset(1, 0)
If MsgBox("Do you want a hyperlink to " & TOC & " on each sheet in cell A1 ?" & Chr(10) & _
"(if cell A1 is empty)", 36, "Hyperlink on each sheet") = vbYes Then
For Each sht In Worksheets
sht.Select
If Cells(1, 1) = "" And sht.Name <> TOC Then ActiveSheet.Hyperlinks.Add Anchor:=Cells(1, 1), Address:="", _
SubAddress:="'" & Worksheets(TOC).Name & "'!A1", TextToDisplay:="TOC"
Next sht
End If
Sheets(TOC).Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The script below is similar, but somewhat different, to the one above.
Sub BuildTOC()
'listed from active cell down 7-cols -- DMcRitchie 1999-08-14 2000-09-05
Dim iSheet As Long, iBefore As Long
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Long
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
mg = ""
CRLF = Chr(10) 'Actually just CR
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 + ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" & CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not $$TOC" & CRLF
If mg <> "" Then
mg = "Warning BuildTOC will destructively rewrite the selected area" _
& CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
& "the affected area will be rewritten, or" & CRLF & _
"Press CANCEL to check area then reinvoke this macro (BuildTOC)"
Application.ScreenUpdating = True 'make range visible
Reply = MsgBox(mg, vbOKCancel, "Create TOC for " & ActiveWorkbook.Sheets.Count _
& " items in workbook" & Chr(10) & "revised will now occupy up to 10 columns")
Application.ScreenUpdating = False
If Reply <> 1 Then GoTo AbortCode
End If
rg.Clear 'Clear out any previous hyperlinks, fonts, etc in the area
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
'hypName = "'" & Sheets(csht).Name
' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace not in XL97
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8# Then
'-- use next line for XL95
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name 'XL95
Else
'-- Only for XL97, XL98, XL2000 -- will create hyperlink & codename
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).CodeName
'--- excel is not handling lots of objects well ---
'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht, cCol), _
' Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1"
'--- so will use the HYPERLINK formula instead ---
'--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
Else
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
End If
Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
' -- activate next line to include content of cell A1 for each sheet
' Cells(cRow - 1 + csht, cCol + 3) = Sheets(Sheets(csht).Name).Range("A1").Value
On Error Resume Next
Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea '.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 7) = Sheets(cSht).PageSetup.PrintArea
If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
On Error GoTo 0
Next cSht
'Now sort the results: 2. Type(D), 1. Name (A), 3. module(unsorted)
rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending, Key2:=rg.Cells(1, 1) _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
rg.Columns.AutoFit
rg.Select 'optional
'if cells above range are blank want these headers
' Worksheet, Type, codename
If cRow > 1 Then
If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) & Cells(cRow - 1, cCol + 2)) Then
Cells(cRow - 1, cCol) = "Worksheet"
Cells(cRow - 1, cCol + 1) = "Type"
Cells(cRow - 1, cCol + 2) = "CodeName"
Cells(cRow - 1, cCol + 3) = "[opt.]"
Cells(cRow - 1, cCol + 4) = "Lastcell"
Cells(cRow - 1, cCol + 5) = "cells"
Cells(cRow - 1, cCol + 6) = "ScrollArea"
Cells(cRow - 1, cCol + 7) = "PrintArea"
End If
End If
Application.ScreenUpdating = True
Reply = MsgBox("Table of Contents created." & CRLF & CRLF & _
"Would you like the tabs in workbook also sorted", _
vbOKCancel, "Option to Sort " & ActiveWorkbook.Sheets.Count _
& " tabs in workbook")
Application.ScreenUpdating = False
'If Reply = 1 Then SortALLSheets 'Invoke macro to Sort Sheet Tabs
Sheets(sSheetName).Activate
AbortCode:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub BuildTOC_A3()
Cells(3, 1).Select
BuildTOC
End Sub