VBA シートの名前が重複するときに すでにある方を削除する

質問

VBA シートの名前が重複するときに　すでにある方を削除する
よろしくお願いします。
エクセル2003を使っています。

「入力シート 」をコピーして「DB」という名前をつける。
すでに「DB]シートがあれば「DB」シートを削除する。
その時に、もし「集計」シートと「名簿」シートがあれば一緒に削除する
というコードを考えています。
集計シートや名簿シートはない場合もありますので、最初からdeleteにするとエラーになります。
どうぞお知恵をお貸しください。

sub シートの挿入と削除 ()
Worksheets("入力シート").Activate
ActiveSheet.Copy After:=ActiveSheet

On Error Resume Next 'エラーが発生しても続行
ActiveSheet.Name = "DB"

If Err.Number = 1004 Then

Application.DisplayAlerts = False '警告メッセージを表示しない
Sheets("DB").Delete

Application.DisplayAlerts = True
ActiveSheet.Name = "DB"

End Sub
End If

回答No.2

myRange · ベストアンサー

>すでに「DB]シートがあれば「DB」シートを削除する。
>その時に、もし「集計」シートと「名簿」シートがあれば一緒に削除する

要するにDB,集計、名簿シートは削除するわけですから
あるかないかを訊く必要はありません。

＞集計シートや名簿シートはない場合もありますので、最初からdeleteにするとエラーになります。

エラーになるという正にそのことを利用すればいいでしょう。

'-----------------------------　
Sub シートの挿入と削除()
　　On Error Resume Next
　　Application.DisplayAlerts = False
　　　　Worksheets("集計").Delete
　　　　Worksheets("名簿").Delete
　　　　Worksheets("DB").Delete
　　Application.DisplayAlerts = True
　　On Error GoTo 0

　　Worksheets("入力シート").Activate
　　ActiveSheet.Copy After:=ActiveSheet
　　ActiveSheet.Name = "DB"
End Sub
'-------------------------------

以上です。

お礼

すばらしい！コードも短くて簡単！
本当にありがとうございました。

回答No.3

okormazd

下記で同でしょう。

Sub シートの挿入と削除()

Worksheets("入力シート").Activate

Application.DisplayAlerts = False '警告メッセージを表示しない

For Each sh In Worksheets
If sh.Name = "DB" Then
sh.Delete
End If
Next

Application.DisplayAlerts = True

ActiveSheet.Copy After:=ActiveSheet

'On Error Resume Next 'エラーが発生しても続行
ActiveSheet.Name = "DB"

'If Err.Number = 1004 Then
'
'Application.DisplayAlerts = False '警告メッセージを表示しない
'Sheets("DB").Delete
'
'Application.DisplayAlerts = True
'ActiveSheet.Name = "DB"
'End If

End Sub

お礼

ありがとうございます。
これだとDBシート以外は削除されませんよね？

回答No.1

mt2008

「○○と言うシートがあるかどうか」をFunctionにしてしまうのはどうでしょう。
「DB」も「集計」「名簿」もそのFunctionで有無を調べてあったら削除です。

Sub シートの挿入と削除()
　'「DB」と言う名前のシートがあるか確認
　If fSheetCheck("DB") = True Then
　　Application.DisplayAlerts = False '警告メッセージを表示しない
　　Sheets("DB").Delete

　　'「集計」と言う名前のシートがあるか確認
　　If fSheetCheck("集計") = True Then Sheets("集計").Delete

　　'「名簿」と言う名前のシートがあるか確認
　　If fSheetCheck("名簿") = True Then Sheets("名簿").Delete
　　Application.DisplayAlerts = True
　End If

　Worksheets("入力シート").Activate
　ActiveSheet.Copy After:=ActiveSheet
　ActiveSheet.Name = "DB"

End Sub

'*** 引数「sName」のシートがあればTrue、無ければFalseを返す
Function fSheetCheck(sName As String) As Boolean
　Dim ws As Worksheet
　fSheetCheck = False

　For Each ws In Worksheets
　　If ws.Name = sName Then
　　　fSheetCheck = True
　　　Exit For
　　End If
　 Next ws
End Function

お礼

ありがとうございます。
まだまだ不勉強でFunctionにするというのがわかりません。
調べてみようと思います。