我有一个包含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
有没有简单的方法可以在所有工作表中一起创建此按钮。
答案 0 :(得分：1)
我会在激活时动态地向工作表添加一个按钮或形状（它们在化妆品方面更令人愉悦）。使用Workbook的SheetActivate事件将其应用于工作簿中的所有工作表。
在WorkBook的SheetActivate中添加此
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
标准模块中的VBA代码：
printf答案 1 :(得分：0)
这听起来像是目录（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