インプットボックスについて

質問

指定したシートを削除するマクロを作っています。１つのシートを指定して削除するマクロはできたのですが、複数のシートを指定して削除するにはどうすればいいか分からなくて困っています。教えて下さい。
Sub 指定して削除()
Application.DisplayAlerts = False
Sheet = InputBox("削除したいシート名を入力して下さい。")
Worksheets(Sheet).Delete
Application.DisplayAlerts = True
End Sub

回答No.7

Wendy02 · ベストアンサー

こんばんは。

実際に立ち上げると、入力例が出ますが、1-10 は、1～10まで、5,6 は、5と6のシート
2,5-10 は、2と5～10　です。

最後に、削除してよいかたずねてきますから、一度、確認してから削除してください。
現行のマクロでは、シート名は、数字型に限ります。

必ず、「標準モジュール」に入れてください。シートモジュールには入れないでください。

-----------------------------------------------------

Sub SheetDeleMac()
Dim ret As Variant
　ret = Application.InputBox("シート名の範囲を入れてください。" & vbCrLf & _
　"入力例：1-10 または、5,6 または、2,5-10", "シート削除", Type:=2)
　If VarType(ret) = vbBoolean Or ret = "" Then Exit Sub
　'区切り文字の半角統一
　ret = Replace(ret, "-", "-", , , 1)
　ret = Replace(ret, ",", ",", , , 1)

　If InputSplit(ret) = False Then
　　MsgBox "すべてのシートを削除することは出来ません。", vbCritical
　　ActiveSheet.Select
　　Exit Sub
　End If
　If MsgBox("選択したシートを削除してよいですか？", vbOKCancel + vbDefaultButton2) = vbOK Then
　　Application.DisplayAlerts = False
　　　　ActiveWindow.SelectedSheets.Delete
　　Application.DisplayAlerts = True
　Else
　　ActiveSheet.Select
　End If
End Sub
Function InputSplit(mStr As Variant)
　　Dim ar As Variant
　　Dim ar2() As Variant
　　Dim ar3() As Variant
　　Dim i As Integer
　　Dim j As Integer
　　Dim v As Variant
　　Dim n As Variant
　　Dim m As Integer
　　Dim sh As Variant
　　Dim tmp As Variant
　　Dim flg As Boolean
　　flg = True
　　ActiveWorkbook.ActiveSheet.Select
　　'カンマで切る
　　ar = Split(mStr, ",")
　　For Each v In ar
　　　　If InStr(v, "-") > 0 Then
　　　　　　For Each n In Split(v, "-")
　　　　　　　　ReDim Preserve ar2(i)
　　　　　　　　ar2(i) = n
　　　　　　　　i = i + 1
　　　　　　Next
　　　　Else
　　　　　　ReDim Preserve ar3(j)
　　　　　　ar3(j) = v
　　　　　　j = j + 1
　　　　End If
　　Next v
　　If UBound(ar2) = 1 Then
　　　　If Val(ar2(0)) > Val(ar2(1)) Then
　　　　　　tmp = ar2(0)
　　　　　　tmp = ar2(0): ar2(0) = ar2(1): ar2(1) = tmp
　　　　End If
　　　　ReDim ar(ar2(1) - 1)
　　　　For i = Val(ar2(0)) To Val(ar2(1))
　　　　　　ar(m) = i
　　　　　　m = m + 1
　　　　Next i
　　End If
　　On Error Resume Next
　　For Each sh In ar
　　　　ActiveWorkbook.Worksheets(sh).Select flg
　　　　flg = False
　　Next
　　For Each sh In ar3
　　　　ActiveWorkbook.Worksheets(sh).Select flg
　　　　flg = False
　　Next
　　If ActiveWindow.SelectedSheets.Count = ActiveWorkbook.Worksheets.Count Then
　　　 InputSplit = False
　　Else
　　　 InputSplit = True
　　End If
　　On Error GoTo 0
End Function

お礼

いつもありがとうございます。
こんな高度なマクロどう考えてもわかりませんでした。
本当にありがとうございます。

回答No.8

Alpha-j

思い切って
This Workbook に以下のコマンドを実装し、削除したいシートのどこかを2回ダブルクリックすると削除できるようにするのはいかがでしょうか

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
End Sub

お礼

こういうやり方もあるんですね。すごく勉強になりました。ありがとうございました。

回答No.6

Alpha-j

ANo.5は誤りでした。テスト済みコードを以下に載せます

1. ThisWorkBook に以下を挿入

Private Sub Workbook_Open()
MsgBox ("Ctrlを押しながらクリックして削除するシートを選んでください" & vbCrLf & "選択が終わったらCtrl+Alt+D を押すと選択したシートが削除されます。")
Application.OnKey "^%d", "DelSheets"
Application.OnKey "^%D", "DelSheets"
End Sub

2. Module1 として以下を記述
Sub DelSheets()
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
End Sub

でいかがでしょうか？
シート名をいちいち入力するのはチョット面倒ですので

回答No.5

Alpha-j

Sub Macro1()
Application.DisplayAlerts = False
Ans = MsgBox("削除するシートをCtrlを押しながらクリックしてください" & crlf & "選択が完了したらOKを押してください", vbOKOnly)
If Ans = vbOK Then
ActiveWindow.SelectedSheets.Delete
End If
End Sub

回答No.4

n-jun

>削除するシートが多いのですが、印刷するときのように「1-10」というような入力の仕方で一度で１～１０のシートを
>削除というようにできないでしょうか？
シート名とシートの配列がどのようになっているのかわかりませんが、
削除したいシートタブをCtrlキーを押しながら左クリックしていき、
右クリックの削除ではダメなのですか？

「1-10」がシート名を示すのか左からの順番を示すのかにもよりますけど。

補足

１、１０は実際のシート名です。
>削除したいシートタブをCtrlキーを押しながら左クリックしていき、
右クリックの削除ではダメなのですか？
この操作ができない人もいるので、マクロでできないかなぁと思いまして・・・

回答No.3

n-jun

ANo.2です。
ちょっとミスりました。

v = Application.InputBox("削除したいシート名を[,、]で区切って入力して下さい", 2)
を
v = Application.InputBox("削除したいシート名を[,、]で区切って入力して下さい", Type:=2)
に置き換えて下さい。

回答No.2

n-jun

都度確認しなくても良ければ、

Sub test()
Dim ws As Worksheet
Dim i As Integer
Dim v, vv

v = Application.InputBox("削除したいシート名を[,、]で区切って入力して下さい", 2)

If v = False Then Exit Sub
vv = Split(Replace(v, "、", ","), ",")
Application.DisplayAlerts = False
For i = 0 To UBound(vv)
Worksheets(vv(i)).Delete
Next
Application.DisplayAlerts = True
End Sub

ご参考程度に。

お礼

削除枚数が少ないものに使わせていただきます。ありがとうございました。

補足

削除するシートが多いのですが、印刷するときのように「1-10」というような入力の仕方で一度で１～１０のシートを削除というようにできないでしょうか？

回答No.1

Alpha-j

Sub 確認しながら削除()
Application.DisplayAlerts = False
For i=1 to worksheets.count
If i > Worksheets.Count then Exit Sub
Sheet_Name=Worksheets(i).name
Ans=Msgbox("シート" & Sheet_Name & "を削除しまか?",vbYesNo)
If Ans=vbYes then Worksheets(i).delete
Next i
End Sub

補足

削除するシートが多いのですが、印刷するときのように「1-10」というような入力の仕方で一度で１～１０のシートを削除というようにできないでしょうか？