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

質問

ボタンが１シート目に２８個並んでいます。
ボタンには、「あああ」「いいい」など、名前が表記されており、まだ「マクロの登録」を行っていません。

「ボタンをクリックすると、ボタンと同じ名前のシートをアクティブにする」
というマクロを、ボタンに登録したいです。

また、常に２８個ボタンがあるというわけではありません。２５個や、２６個になる場合もあります。

※１シート目にボタンを作り、そのボタンに名前を付ける作業は、
　 前回教えていただいた下記のマクロを行いました。

Sub ボタン設置()
With Worksheets(1)
For i = 1 To (Worksheets.Count - 1)
nX = 145 * (1 + ((i - 1) Mod 8))
nY = 30 * (1 + Int(i / 8))
.Buttons.Add(nX, nY, 140, 20).Text = Worksheets(i + 1).Range("I2").Value
Next i
End With
End Sub

回答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文字までしか入力出来ないため、残りは又後で投稿致します。

お礼

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

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

回答No.8

misatoanna

#4misatoanna です。

「アクティブシート上のすべてのボタンを選択してマクロを登録」というマクロ。

Sub QQQ()
　Dim shp
　For Each shp In ActiveSheet.Buttons
　　shp.OnAction = "Test"
　Next
End Sub

お礼

ご回答ありがとうございます！
作業が完了しましたのでお礼申し上げます。

またよろしくお願いいたします。

回答No.7

kagakusuki

回答No.6の続きです。

For i = 2 To Sheets.Count
With FirstCell.Offset(YPitch * (i - 1), XPitch * (i - 1))
If .MergeCells Then
Set PasteCell = .Resize(1, 1).MergeArea
Else
Set PasteCell = .Offset()
End If
End With
With PasteCell
CoordX = .Left + .Width / 2 - ShapeW / 2
CoordY = .Top + .Height / 2 - 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
End With
Set PasteShepe = FirstShepe.Duplicate
With PasteShepe
.Left = CoordX
.Top = CoordY
.Characters.Text = Sheets(i).Name
End With
Next i

GoTo labelEnd:

label3:
myBox = Empty
On Error Resume Next
Set myBox = Application.InputBox( _
Prompt:=myInfo(1) & "のボタンを貼り付けるセルを、" _
& vbCrLf & "マウス等を使って選択するか、或いは" _
& vbCrLf & "セル番号をA1形式で入力する事で指定して下さい。" _
, Title:=myInfo(0), _
Default:=ActiveCell.Address, Type:=8)
If IsError(myBox.Row) Then
myBox = MsgBox("セルが選択されていません" & vbCrLf & "セルの選択をやり直しますか？" _
& vbCrLf & vbCrLf & "[再試行]:セルの選択のやり直し" & vbCrLf & "[キャンセル]:マクロの終了" _
, vbRetryCancel + vbExclamation + DefaultButton2, "無効な選択")
If myBox = vbRetry Then GoTo label3
Exit Sub
End If
On Error GoTo 0
Return

label4:
MsgBox "その設定では、セルが存在する範囲(A1:" _
& Cells(Rows.Count, Columns.Count).Address(False, False) _
& ")の外に" & vbCrLf _
& "最後のボタンを配置しなければならない事になります。" _
& vbCrLf & "ボタン配置の設定をやり直して下さい。" _
, vbExclamation, "無効な設定"
GoTo label1

labelEnd:

End Sub

　以上です。

お礼

ありがとうございました！

回答No.5

kagakusuki

回答No.1の改良案です。

Sub QNo8986361_マクロ_ボタンと同じ名前のシートをアクティブにする_改()

Dim ButtonText As String

ButtonText = ActiveSheet.Shapes(Application.Caller) _
.TextFrame.Characters.Text

If IsError(Evaluate("ROW('" & ButtonText & "'!A1)")) Then
MsgBox "押されたボタンのテキストにある" & vbCrLf _
& vbCrLf & ButtonText & vbCrLf & vbCrLf & _
"という名前と同名のシート名を持つシートが見つかりません。" _
, vbExclamation, "無効なシート名"
Exit Sub
Else

Sheets(ButtonText).Activate

End If

End Sub

　因みに、上記のマクロや回答No.1のマクロでは、万が一、ボタンのテキストに入力されている文字列を間違えた場合(どのシート名とも異なる文字列としてしまった場合)や、ボタンのテキストにシート名を入力した後で該当するシート名が変更されてしまった場合であっても、「シートが見つかりません」という御知らせが表示されるだけで、「マクロ自体がエラーとなってVBAのウィンドウで対処しなければならない」様な羽目にはなりませんので、ボタンのテキストやシート名を変更する際にも、「ボタンを押してみて間違っていたら直せば良い」とい考えで気楽にボタンのテキストやシート名を変更する事が出来ます。
　尚、回答No.2様のマクロでも、上記の点は同様の仕様になっている様です。

お礼

失礼いたします。
補足コメントで書かせていただいたことは、こちらのミスでした。
回答者様に教えていただいた方法で、無事作業を実行することができました。
本当にありがとうございます。

そこで、重ねての質問になり大変恐縮なのですが、
今回はボタンが２８個ですが、５個の時もあれば、１０個の時もあります。
回答者様に教えていただいた「ボタンを複数選択して、マクロの登録」
の一連の流れをマクロに登録し、他のブック（例えばボタンが５個のシート）でも適応させたいと
考えています。
『アクティブになっているシートにあるボタンをすべて選択し、「QNo8986361_マクロ_ボタンと同じ名前のシートをアクティブにする_改()」をボタンにマクロ登録する』
といったようなことはできないでしょうか？

説明がわかりづらく失礼いたします。
分かったらでいいので教えていただければと思います。
重ね重ねすみませんが、よろしくお願いいたします。

補足

ご回答、また改良案までご教授いただき、ありがとうございます。

回答者様のマクロを行ってみたところ、

ButtonText = ActiveSheet.Shapes(Application.Caller) _
.TextFrame.Characters.Text

のところでエラーになります。
「指定した名前のアイテムが見つかりませんでした。」
と表示されます。

申し訳ありませんが、原因が分かれば教えていただきたいです。

回答No.4

misatoanna

ご質問のマクロで作成されるボタンはフォームのボタンのようですので、作成されたすべてのボタンを選択し、右クリックから次のマクロを登録してください。

Sub Test()
　Dim sh
　sh = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
　Sheets(sh).Activate
End Sub

お礼

ご回答ありがとうございました！
参考にさせていただきました！

補足

ご回答ありがとうございます！

重ねての質問になり大変恐縮なのですが、
今回はボタンが２８個ですが、５個の時もあれば、１０個の時もあります。
回答者様に教えていただいた「ボタンを複数選択して、マクロの登録」
の一連の流れをマクロに登録し、他のブック（例えばボタンが５個のシート）でも適応させたいと
考えています。
『アクティブになっているシートにあるボタンをすべて選択し、「Test()をボタンにマクロ登録する』
といったようなことはできないでしょうか？

説明がわかりづらく失礼いたします。
分かったらでいいので教えていただければと思います。
すみませんが、よろしくお願いいたします。

回答No.3

mt2008

次はこの内容の質問が来るんじゃないかと思っていました。
指定のシートを選択する「シート選択」と言うマクロを用意し、ボタン設置の時にそのマクロに引数でシート名を渡す様に設定しましょう。
ついでに、各シートのI2セルにシート名を入れなくてもWorksheets(n).Nameでシート名が取得できますよ。
＃OnAction 引数の「”」と「’」の位置と数を間違えない様にご注意を

Sub ボタン設置()
　　With Worksheets(1)
　　　　For i = 1 To (Worksheets.Count - 1)
　　　　　　nX = 145 * (1 + ((i - 1) Mod 8))
　　　　　　nY = 30 * (1 + Int(i / 8))
　　　　　　sName = Worksheets(i + 1).Name
　　　　　　With .Buttons.Add(nX, nY, 140, 20)
　　　　　　　　.Text = sName
　　　　　　　　.OnAction = "'シート選択""" & sName & """'"
　　　　　　End With
　　　　Next i
　　End With
End Sub
Sub シート選択(sShtName As String)
　　Worksheets(sShtName).Select
End Sub

お礼

ご回答ありがとうございます。
ご回答者様のご教授くださったマクロを参考にさせていただきました。

丁寧に教えてくださったにも関わらず大変恐縮ですが、
何度も改善案等提案して下さった別の回答者様をベストアンサーに選定いたしました。
本当にすみません。。。

ありがとうございました！

補足

ご回答ありがとうございます！

回答者様のマクロを実行したところ、ボタンをクリックすると
アクティブにならないボタンが何個がありました。
見てみると、
「名前に『大文字の英語』を含むボタン」がエラー対象のようです。

回答者様の方法でぜひとも作業を進めたいと考えておりますので、
もし原因が分かるようでしたら、教えていただきたいです。
重ね重ね質問してしまい、大変申し訳ございません。
よろしくお願いします。

回答No.2

keithin

手順：
「あああ」ボタンを残し，他のボタンは全て消去する
「あああ」ボタンに次のマクロを登録する

sub macro1()
　dim s as string
　s = activesheet.shapes(application.caller).oleformat.object.caption
　on error goto errhandle
　worksheets(s).select
　exit sub

errhandle:
　msgbox "WORKSHEET " & s & " NOT EXIST"
end sub

あああボタンではなく「あああボタンが乗っているセル範囲」をコピー，必要な数だけ貼り付けてそのまま数を増やす（セル範囲のオートフィルドラッグでＯＫ）（マクロを登録し直す必要は全くない）
各ボタンに正しいシート名を記入する

お礼

ご回答ありがとうございます！
作業が完了いたしましたのでお礼申し上げます。

回答No.1

kagakusuki

>ボタンには、「あああ」「いいい」など、名前が表記されており、まだ「マクロの登録」を行っていません。

　以下の様なマクロをそれらのボタンに登録してみて下さい。
　因みに、[Ctrl]キーを押しながらそれらのボタンをクリックして行く事で複数のボタンをまとめて選択する事が出来ますので、その上で、選択済みのボタンの内の1つを右クリックすると現れる選択肢の中から、[マクロの登録]をクリックし、[マクロの登録]ダイアログボックスにおいて下記のマクロを選択する事で、複数のボタンに同時に同じマクロを登録する事が出来ます。
　または、下記のマクロを登録済みのボタンをコピー(或いは右ドラッグ後、[ここにコピー]を選択)してから、新たに出来たコピーボタンのテキストを編集するといった方法でも同様の結果が得られます。

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

Dim ButtonText As String

ButtonText = ActiveSheet.Shapes.Range(Application.Caller) _
.TextFrame.Characters.Text

If IsError(Evaluate("ROW('" & ButtonText & "'!A1)")) Then
MsgBox "押されたボタンのテキストにある" & vbCrLf _
& vbCrLf & ButtonText & vbCrLf & vbCrLf & _
"という名前と同名のシート名を持つシートが見つかりません。" _
, vbExclamation, "無効なシート名"
Exit Sub

Else
Sheets(ButtonText).Activate

End If

End Sub

お礼

ご回答ありがとうございます！
無事作業することができました！