返回索引按鈕

Question

我有一個包含208張工作表和彙總表的excel文件。想要創建一個按鈕來跳轉到每張表。我正在使用下面的代碼。

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 

回到彙總表很困難。所以用按鈕創建的宏

Private Sub CommandButton1_Click() 

Sheets("SummarySheet").Select 

End Sub 

是否有任何簡單的方法可以在所有工作表中一起創建此按鈕。

Answer 1

當紙張被激活時，我會添加一個按鈕或形狀（它們在化妝品方面更令人愉悅）。使用工作簿的SheetActivate事件將其應用於工作簿中的所有工作表。

在工作簿中的SheetActivate標準模塊中添加此

Private Sub Workbook_SheetActivate(ByVal Sh As Object) 
    Call addButton 
End Sub 

VBA代碼：

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

這聽起來像的內容（TOC）問題的表。複製/粘貼下面的代碼，看看它是否基本上做到了你想要的。

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 

下面的腳本與上面的腳本類似，但有所不同。

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