Excel VBA シート削除の繰り返しにおいて

EXCEL　2002　シート削除の連続削除において分からない事があるので質問いたします。あるシートのボタンを押すと、そのシートの種族と同じ種族で、種族の子番号が、そのシートよりも大きいものを削除したいと思います。
シート番号　1 スタートページ
シート番号　2　種族 １ (textbox1).value 子番号　1 (textbox2).value
シート番号　3　種族 2 (textbox1).value 子番号　1 (textbox2).value
シート番号　4　種族 2 (textbox1).value 子番号　2　(textbox2).value ←　削除ボタンを押したシート（削除したい）
シート番号　5　種族 2 (textbox1).value 子番号　3 (textbox2).value　←削除したい
シート番号　6　種族 3 (textbox1).value 子番号　1 (textbox2).value　←削除したくない

シートに削除機能を設けると、オートメーションエラーがでてくるので、オートメーションエラーがでないように、標準モジュールに削除プロシージャを作成して、そのプロシージャを呼び出す形をとっています。また、よけいな、注意書き等（削除の時必ずでてきて、連続操作をとめる警告文を防ぐために、　Application.DisplayAlerts = False )を　呼び出すシートモジュールと、呼び出されたモジュールの両方で、設けております。
下記のようにいたしましたが、「オートメーションエラー」のメッセージがでてきて、デバッグ前に実行時のエラーで終わります。
上記の目的を達成するために、オートメーションエラーを表示させずに、無事連続シート削除を達成するにはどうすればよろしいでしょうか。どなたか連続削除の経験等ある方いらっしゃいましたら、お願いいたします。

呼び出すシート側のプロシージャ
Private Sub deletebutton_Click()
Call delete '削除関数
Application.DisplayAlerts = True
End Sub

呼び出された標準モジュール
Option Explicit
Const worksheets_start As Integer = 2
'削除可能シート番号　（２から削除可能

' 削除プロシージャ
Public Sub delete()
Dim no, i, j As Integer
Dim ws As Worksheet
Application.DisplayAlerts = False
‘余計な警告文をださない。
MsgBox "シートNOを削除いたします。", vbOKCancel
If Worksheets.Count < worksheets_start Then
‘シート２以下は削除させない（今回は4から削除
MsgBox "これ以上、削除できるシート番号がありません。"
GoTo sayonara
Else
no = ActiveSheet.Index
'削除を指定したページのページ番号取得
i = Worksheets.Count
‘シートの総シート数取得
For j = worksheet_start To Worksheets.Count
‘共通変数のシートスタート（ 2 ）
'種族２の子番号２以上のシートがあれば、全て削除したい
Worksheets(i).Activate 　
'最終ページにアクティブを移動
If i = worksheets_start Then
'　最終シートからチェック
i カウントがスタートページまでいったら終了
Exit For
End If
If no <> i Then ‘　削除ボタンを押したシートは念の為消さない
If Val(Worksheets(i).TextBox4.Value) = _
Val(Worksheets(no).TextBox4.Value) Then
'種族が同じ(同種族)
If Val(Worksheets(i).TextBox5.Value) > _
Val(Worksheets(no).TextBox5.Value) Then
'同種族の子番号が削除指定したシートの子番号よりも大きい
Worksheets(i).delete ‘　該当シート削除
MsgBox "削除" & I ‘　シートiの削除メッセージ
i = i - 1
‘　シート削除対象を一つ減らす　
Else
‘　子番号が削除ボタンを押したシートの子番号より小さい
i = i - 1　　　　　　　
End If
End If
End If
Next
End If
sayonara:
Application.DisplayAlerts = True
End Sub
参照ページ
http://www.big.or.jp/~seto/vbaref/vbaref7.htm​
http://www.relief.jp/itnote/archives/001936.php​
http://oshiete1.goo.ne.jp/qa2782689.html​
みにくくて申し訳ありません。

No.1 ベストアンサー 回答者： Wendy02 回答日時： 2008/02/08 11:57

こんにちは。

最初に、基本的に、プロパティやメソッドの名称をプロシージャ名に使うのは、うまくありません。エラーにはならないけれど、書きません。×　Sub Delete() はいけません。
それから、コードは、もう少し丁寧に、VBEditor 上で書いてからにしてください。

オートメーションエラーの原因は、たぶん、コントロール・オブジェクトをマクロで参照しながら、それ自体を削除しようとしているからだと思います。

コードと説明とは合致していないのは、

>If Val(Worksheets(i).TextBox4.Value) = _
>Val(Worksheets(no).TextBox4.Value) Then
>'種族が同じ(同種族)
>If Val(Worksheets(i).TextBox5.Value) > _
> Val(Worksheets(no).TextBox5.Value) Then

なぜ、TextBox4, TextBox5 が出てくるのでしょうか？文章の説明では、TextBox1, TextBox2 ではないでしょうか？


以下は、"TextBox1", "TextBox2 " で参照するように出来ています。
ボタンで、Call SheetDeleteMacro としてください。


'-------------------------------------------------

Sub SheetDeleteMacro()
Dim i As Integer
Dim n As Integer, m As Integer
Dim x As Integer, y As Integer
Dim k As Integer
Dim dummy As Variant
Dim arDelShts() As Variant

Const WS_START As Integer = 2
If Worksheets.Count = 1 Then
　 MsgBox "シートが1つの時は実行できません！", 48
　 Exit Sub
End If
On Error GoTo ErrorHandler
With ActiveSheet
　　n = Val(.TextBox1.Value)
　　m = Val(.TextBox2.Value)
End With

For i = 2 To Worksheets.Count
　With Worksheets(i)
　　x = Val(.TextBox1.Value)
　　y = Val(.TextBox2.Value)
　End With
　If x = n And y > m Then
　　 ReDim Preserve arDelShts(k)
　　 arDelShts(k) = i
　　 k = k + 1
　End If
Next i
On Error Resume Next
dummy = UBound(arDelShts)
If Err.Number = 9 Then
　 MsgBox "削除するシートは見たありません！", 48
　 Exit Sub
End If

On Error GoTo 0

If MsgBox("シートの順番の" & Join(arDelShts, ",") & _
　 "を削除します", vbOKCancel) = vbOK Then

　 Application.DisplayAlerts = False
　　　Worksheets(arDelShts).Delete
　 Application.DisplayAlerts = True
End If
Exit Sub
ErrorHandler:
　MsgBox Err.Number & ": " & Err.Description
End Sub

この回答へのお礼

こんにちは。

見事に、エラーを全く出すことなく、しかも、当初の希望にプラスアルファの確認メッセージまでついた結果を出すことができました。

当方の編集過程で至らない点が多々ある中、教えていただきありがとうございました。

見事すぎる結果に当方も何度もWendy02様のコードを読み返しております。
連続シートの削除は配列で、という記述をネットで検索したのですが、当方には、ちょっと、挑戦できるスキルがありませんでした。

　If x = n And y > m Then
　　 ReDim Preserve arDelShts(k)
　　 arDelShts(k) = i
　　 k = k + 1
　End If

秀逸であります。

重ね重ねありがとうございました。

お礼日時：2008/02/08 12:38