インデックスボタンに戻る

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