返回索引button
我有一个有208张表格和一张汇总表的excel文件。 想要创build一个button来跳转到每个工作表。 我正在使用下面的代码。
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 回到汇总表是困难的。 所以用button创buildmacros
Private Sub CommandButton1_Click() Sheets("SummarySheet").Select End Sub
是否有任何简单的方法可以在所有表单中一起创build此button。
当它激活时，我会添加一个button或形状（它们在化妆品方面更令人愉悦）。 使用工作簿的SheetActivate事件将其应用于工作簿中的所有工作表。
在WorkBook的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
这听起来像是一个目录（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