| |
こんにちは。
仕様が違いますが、私が使っているやつから抜粋してみました。
右クリックメニューにボタンを作成。
シート数60枚までですが..。
標準モジュール
'右クリックメニュー追加
Sub Auto_Open()
右クリメニュー追加
End
End Sub
Sub 右クリメニュー追加()
'On Error Resume Next
Set 右クリメニュー = Application.CommandBars("cell").Controls.Add _
(Type:=msoControlButton, temporary:=True)
With 右クリメニュー
.Caption = "選択（複数）"
.FaceId = 264
.OnAction = "シート複数選択"
End With
With Application.CommandBars("Cell")
'.Reset
End With
End Sub
Sub シート複数選択()
UserForm1.Show
End Sub
フォームモジュール
（注）フォーム上のボタンとかその他の類は一切いりません。
マクロで都度作ってます。
Public WithEvents CmBottan21 As MSForms.CommandButton
Public WithEvents CmBottan22 As MSForms.CommandButton
Dim i As Long, j As Long, n As Long, WShC As Long, CheckCnt As Long
Dim ボタン位置高 As Single, 実行ボタン位置横 As Long, 繰返し As Long
Const 行間隔 = 16, ボタン基準値 = 50 '52.25
Const チェック標準数 = 5
Private Sub CmBottan21_Click()
Unload Me
End
End Sub
Private Sub CmBottan22_Click()
Dim ShTBL() As String
CheckCnt = 0
Application.DisplayAlerts = False
For i = 1 To 繰返し
If Me.Controls("MCheckBox" & i) = True Then
CheckCnt = CheckCnt + 1
End If
Next
CheckCnt = 0
For i = 1 To 繰返し
If Me.Controls("MCheckBox" & i) = True Then
CheckCnt = CheckCnt + 1
ReDim Preserve ShTBL(1 To CheckCnt)
ShTBL(CheckCnt) = Me.Controls("MCheckBox" & i).Caption
End If
Next
Unload Me
Application.DisplayAlerts = True
On Error Resume Next
ert = ShTBL(1)
If Err = 0 Then
Sheets(ShTBL).Select
End If
Err.Clear
On Error GoTo 0
Erase ShTBL
End
End Sub
Private Sub UserForm_Initialize()
n = 0: WShC = Worksheets.Count
Me.Width = 240
Me.Caption = "シート選択"
Select Case WShC
Case Is <= 10
j = 5
Me.Height = 140.25 '標準状態
ボタン位置高 = Me.Height - ボタン基準値
実行ボタン位置横 = 135
繰返し = WShC
Case Is <= 16
j = Application.RoundUp(16 / 2, 0)
Me.Height = 140.25 + 行間隔 * (j - チェック標準数)
ボタン位置高 = Me.Height - ボタン基準値
実行ボタン位置横 = 135
繰返し = WShC
Case Is <= 20
j = Application.RoundUp(20 / 2, 0)
Me.Height = 140.25 + 行間隔 * (j - チェック標準数)
ボタン位置高 = Me.Height - ボタン基準値
実行ボタン位置横 = 135
繰返し = WShC
Case Is <= 30
j = Application.RoundUp(30 / 3, 0)
Me.Height = 140.25 + 行間隔 * (j - チェック標準数)
ボタン位置高 = Me.Height - ボタン基準値
実行ボタン位置横 = 340 - 105 '340 - 150
繰返し = WShC
Me.Width = 340
Case Is <= 35
j = Application.RoundUp(35 / 3, 0)
Me.Height = 140.25 + 行間隔 * (j - チェック標準数)
ボタン位置高 = Me.Height - ボタン基準値
実行ボタン位置横 = 340 - 105
繰返し = WShC
Me.Width = 340
Case Is <= 45
j = Application.RoundUp(45 / 3, 0)
Me.Height = 140.25 + 行間隔 * (j - チェック標準数)
ボタン位置高 = Me.Height - ボタン基準値
実行ボタン位置横 = 340 - 105
繰返し = WShC
Me.Width = 340
Case Is <= 60
j = Application.RoundUp(60 / 4, 0)
Me.Height = 140.25 + 行間隔 * (j - チェック標準数)
Me.Width = 440
ボタン位置高 = Me.Height - ボタン基準値
実行ボタン位置横 = Me.Width - 105
繰返し = WShC
Case Else
MsgBox "シート枚数が多すぎます。" & vbCrLf & _
"現在のシート枚数には、対応しておりません。" & vbCrLf & _
"最高60枚、それ以上は表示されません。"
j = Application.RoundUp(45 / 3, 0)
Me.Height = 140.25 + 行間隔 * (j - チェック標準数)
Me.Width = 440
ボタン位置高 = Me.Height - ボタン基準値
実行ボタン位置横 = Me.Width - 105
繰返し = 60
'Exit Sub
End Select
For i = 1 To 繰返し
If n = j Then
n = 0
End If
n = n + 1
Set CheckBox追加 = Me.Controls.Add("Forms.CheckBox.1", "MCheckBox" & i)
With Me.Controls("MCheckBox" & i)
If i <= j Then
.Left = 15
ElseIf i <= j * 2 Then
.Left = 120
ElseIf i <= j * 3 Then
.Left = 225
Else
.Left = 325
End If
If n = 1 Then
.Top = 0
Else
.Top = n * 行間隔 - 行間隔
End If
.Height = 行間隔
.Caption = Worksheets(i).Name
End With
Next
Set CmBottan21 = Me.Controls.Add("Forms.CommandButton.1", "終了ボタン")
With Me.Controls("終了ボタン")
.Caption = "終 了"
.Width = 75
.Top = ボタン位置高
.Left = 25
.SetFocus
End With
Set CmBottan22 = Me.Controls.Add("Forms.CommandButton.1", "選択ボタン")
With Me.Controls("選択ボタン")
.Caption = "シートの選択"
.Width = 75
.Top = ボタン位置高
.Left = 実行ボタン位置横 '135
End With
End Sub
|
|
Jaka
- 04/12/16(木) 10:01 -
