複数のシートを選択している状態なので、リボン(メニューバー)にボタンを追加
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
Sub test() Application.CommandBars("worksheet menu bar").Reset End Sub Sub auto_open() On Error Resume Next caption = "選択一覧" For x = 1 To 3 Application.CommandBars("worksheet menu bar").Controls(caption).Delete Next With Application.CommandBars("worksheet menu bar").Controls.Add(Type:=msoControlButton) .Style = msoButtonCaption .caption = caption .OnAction = "main" End With End Sub Sub auto_close() caption = "選択一覧" On Error Resume Next For x = 1 To 3 Application.CommandBars("worksheet menu bar").Controls(caption).Delete Next End Sub Sub Initialize() Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False End Sub Sub Finalize() Application.DisplayAlerts = True Application.EnableEvents = True Application.ScreenUpdating = True End Sub Sub main() Initialize caption = "選択一覧" exists = False For Each w In Sheets If w.Name = caption Then exists = True Exit For End If Next w If exists = False Then MsgBox caption & "シートが存在しません。" Exit Sub End If Sheets(caption).Rows("1:1000").Delete r = 1 For Each w In ActiveWindow.SelectedSheets If w.Name <> caption Then w.Range("A2:AD22").Copy Sheets(caption).Cells(r, 1).PasteSpecial xlPasteValues w.Range("A2:AD22").Copy Sheets(caption).Cells(r, 1).PasteSpecial xlPasteFormats End If r = r + 23 Next w Sheets(caption).Select Application.CutCopyMode = False Finalize End Sub |