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

質問

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

回答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

　以上です。

お礼

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