マクロボタンと同じ名前のシートをアクティブにする

質問

• 28個のボタンが1シート目に並んでいます。ボタンには名前が表記されており、まだマクロの登録は行われていません。ボタンをクリックすると、ボタンと同じ名前のシートをアクティブにするマクロを登録したいです。また、ボタンの数は常に28個ではなく、25個や26個になる場合もあります。
• 28個のボタンがあり、ボタンには名前が表記されています。まだマクロの登録は行われていません。ボタンをクリックすると、ボタンと同じ名前のシートをアクティブにするマクロを作成したいです。ただし、ボタンの数は常に28個ではなく、25個や26個になる場合もあることに注意してください。
• 28個のボタンが1シート目に並んでいます。ボタンには名前がありますが、マクロの登録はまだ行われていません。ボタンをクリックすると、ボタンと同じ名前のシートをアクティブにするマクロを作成したいです。ただし、ボタンの数は常に28個ではなく、25個や26個になる場合もあります。

回答No.6

kagakusuki · ベストアンサー

>『アクティブになっているシートにあるボタンをすべて選択し、「QNo8986361_マクロ_ボタンと同じ名前のシートをアクティブにする_改()」をボタンにマクロ登録する』
>といったようなことはできないでしょうか？

　やってやれない事はないとは思いますが、それですともし他のマクロを登録して使用しているボタンがあった場合、そのボタンのマクロの登録が上書きされて、それまで使っていた別のマクロを一々、登録し直さなければならない羽目になりかねませんから、その様なやり方は止めておかれた方が無難だと思います。
　そこで別の方法として、回答No.3様が提案されておられた方法と同様に、
「『QNo8986361_マクロ_ボタンと同じ名前のシートをアクティブにする_改()』のマクロが登録済みで、尚且つ、各シート名に合わせた文字列をテキストに入力済みとなっているボタンを、Workbook内に存在している全シート枚数分作成する」
というマクロを組んでみました。
　ただ、回答No.3様のマクロでは、シートのレイアウトには関係なく、ボタンが配置される場所が固定となっていて、ボタンの配置を変更する際にはマクロの構文に記されている数値を変更せねばならない様でしたので、その点を改良しております。(改良と書きましたが、別に回答No.3様のマクロをベースにしている訳ではなく、新規に組んだものです)
　使い方は、まず先に「QNo8986361_マクロ_ボタンと同じ名前のシートをアクティブにする_改()」のマクロをExcelファイルの標準モジュールに保存しておきます。
　その上で、今回のマクロを起動させた際に現れるダイアログボックスの指示に従って、1つ目のボタンを配置したいセル(結合セル、或いはセル範囲も可)を選択し、次に2つ目のボタンを配置したいセルを選択しますと、1番目のセルと2番目のセルの行番号と列番号の差を読み取って、1番目のセルを基点として一定の行間隔と列間隔で、各セル又はセル範囲の中心と、ボタンの中心が一致する様にボタンを配置して行く様になっております。(縦横どちらの方向にも並べる事が出来ます。縦横どちらでも可となる様にした結果、ついでに斜め方向に並べる事も出来る様になってしまっております)
　途中に行の高さや列幅が異なるセルが存在していた場合でも、各セル又はセル範囲の中心に合わせてボタンが配置されます。
　但し、ボタンのサイズは各シートの中で最も長いシート名に合わせて調整されますので、行の高さや列幅が不足している場合には、ボタンがセルからはみ出してしまいますので、このマクロを使用する前に予めセルの高さや幅を調整しておく事を御勧め致します。

　後それから、上記のマクロを使った結果、ボタンが増え過ぎてしまう様な事になった場合に備えて、「選択したセル範囲と重なっている図形(ボタンも含む)を全て削除するマクロ」が掲載されているサイトへのリンクを貼っておきます。

【参考URL】
　インストラクターのネタ帳 > エクセルマクロ・Excel VBAの使い方 > マクロのサンプル > 選択したセル範囲に含まれる図形を削除するExcelマクロ
　　http://www.relief.jp/itnote/archives/018407.php

Sub テキストに表示されている名前のシートを開くボタンを自動作成()

Dim MaxName As String
Dim myOnAction As String
Dim i As Long
Dim myBox As Variant
Dim myTemp As Variant
Dim FirstCell As Range
Dim PasteCell As Range
Dim myInfo(1) As String
Dim XPitch As Integer
Dim YPitch As Long
Dim CoordX As Single
Dim CoordY As Single
Dim ShapeH As Single
Dim ShapeW As Single
Dim FirstShepe As Object
Dim PasteShepe As Object

'ボタンに登録するマクロ
myOnAction = _
"QNo8986361_マクロ_ボタンと同じ名前のシートをアクティブにする_改"

label1:
myInfo(0) = "ボタン配置開始位置の指定"
myInfo(1) = "最初"
GoSub label3
If myBox.MergeCells Then
Set FirstCell = myBox.Resize(1, 1).MergeArea
Else
Set FirstCell = myBox
End If
FirstCell.Parent.Select
FirstCell.Activate

label2:
myInfo(0) = "ボタン配置間隔の指定"
myInfo(1) = "2つ目"
GoSub label3

YPitch = myBox.Row - FirstCell.Row
XPitch = myBox.Column - FirstCell.Column
If YPitch = 0 And XPitch = 0 Then
MsgBox "その設定では全てのボタンが同じ位置で重なってしまいます。" _
& vbCrLf & "ボタンを配置する間隔の設定をやり直して下さい。" _
, vbExclamation, "無効な設定"
Goto label2
End If
myTemp = Empty
myTemp = FirstCell.Row + YPitch * (Sheets.Count - 1)
If myTemp < 1 Or myTemp > Rows.Count Then GoTo label4
myTemp = FirstCell.Column + XPitch * (Sheets.Count - 1)
If myTemp < 1 Or myTemp > Columns.Count Then GoTo label4

For i = 1 To Sheets.Count
If Application.Evaluate("LENB(""" & Sheets(i).Name & """)") > _
Application.Evaluate("LENB(""" & MaxName & """)") Then _
MaxName = Sheets(i).Name
Next i

With FirstCell
CoordX = .Left + .Width / 2
CoordY = .Top + .Height / 2
Set FirstShepe = .Parent.Buttons.Add(1, 1, 1, 1)
End With
With FirstShepe
.Characters.Text = MaxName
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Placement = xlMove
.PrintObject = Falsel
.AutoSize = True
.AutoSize = False
ShapeH = .Height
ShapeW = .Width
CoordX = CoordX - ShapeW / 2
CoordY = CoordY - ShapeH / 2
If CoordX < 1 Then CoordX = 1
With .Parent.Columns(Columns.Count)
If CoordX + ShapeW > .Left + .Width Then _
CoordX = .Left + .Width - ShapeW
End With
If CoordY < 1 Then CoordY = 1
With .Parent.Rows(Rows.Count)
If CoordY + ShapeH > .Top + .Height Then _
CoordY = .Top + .Height - ShapeH
End With
.Left = CoordX
.Top = CoordY
.Characters.Text = Sheets(1).Name
.OnAction = myOnAction
End With

　※　まだ途中なのですが、このサイトの回答欄は4000文字までしか入力出来ないため、残りは又後で投稿致します。

お礼

何度も質問したにも関わらず丁寧なご回答ありがとうございます！
無事作業が完了したのでお礼申し上げます。

今後もよろしくお願いいたします。
本当にありがとうございました。