VBA シートをコピーした時、同名の場合は注意喚起

質問

いつもお世話になります。
WINDOWS7 EXCELL2010 です。

下記のマクロで例えば、
「1018」というシートが既に存在していて新たに「1018」を作成しようとした時に重複の注意喚起メッセ―ジを出すには下記のマクロにどうすればいいか御指導いただけませんでしょうか。

注意喚起メッセージは　　「既に、同名のシートがあり再度入力して下さい。」
※If MsgBox("既に、同名の シートがあり再度入力して下さい。")

参考に
Private Sub CommandButton1_Click()

Dim NewSheetName As String

NewSheetName = InputBox("一桁の月及び日でも二桁のMMDD形式で新しいシート名を入力してください。例 0101")

Sheets("元本").Copy After:=Sheets("元本")
With ActiveSheet
.Name = NewSheetName
With .Range("A1")
.NumberFormatLocal = "0000"
.Value = NewSheetName
End With
.OLEObjects("CommandButton1").Delete
.Range("A2").Select
End With
Sheets("元本").Activate
Application.ScreenUpdating = True

End Sub

回答No.3

kkkkkm · ベストアンサー

> ご回答いただいたのをそのまま反映したものが下記の　「１」　ですがテストしたところシートのコピーなど何も反応しませんでした。

回答は、同一シート名に対し注意喚起し再入力を求めるという部分のコードですから、回答１の最後に「以下に新規作成のコード 」と記載しているように、質問のSheets("元本").Copy After:=Sheets("元本")以下のコードをそのまま記載してください。

> 私なりにご回答を編集追加したところ、
> シートはコピーされ　同名のシート名は「既に、同名の シートがあり再度入力して下さい。」
> までは上手くできました。
> ただしその後は下記のようなコーションが出ました。
> 解決策を再度ご指導いただけませんでしょうか。

一番大事なdo～Loopを取り除いてますから、同じシート名を見つけてもその旨表示するだけで再度入力をさせるようになっていません。その為に、重複するシート名のまま先に進み名前変更しようとしてますから当然「同じシート名で変更しようとしている」というエラーになります。

お礼

早速の再ご指導誠にありがとございました。
上手くできて楽しんでいます。
未熟でご迷惑かけました。

回答No.2

kkkkkm

No1の一部追加です

同じシート名が見つかってもさらに探していたので見つかった時点でループを抜けるようにExit For追加しました。

For Each c In Worksheets
If c.Name = NewSheetName Then
MatchFLG = True
MsgBox ("既に、同名の シートがあり再度入力して下さい。"), vbExclamation
Exit For '←ここに追加
End If
Next

あと、質問のコードではMMDD以外の入力を規制していませんが、参考なので割愛しているのでなければ以下のページを参考に規制してみてはいかがでしょう。
http://atamoco.boy.jp/vba/lang/date.time/IsDate.php

補足

ご回答いただいたのをそのまま反映したものが下記の　「１」　ですがテストしたところシートのコピーなど何も反応しませんでした。

それ故にご回答に対して失礼かと思いつつも　２　のように勝手に変更させて戴きました。
２　の不具合の解決も含めて再度ご指導いただけたら幸甚の至りです。

１
Private Sub CommandButton1_Click()
Dim NewSheetName As String
Dim c As Object
Dim MatchFLG As Boolean

Do
MatchFLG = False
NewSheetName = InputBox("一桁の月及び日でも二桁のMMDD形式で新しいシート名を入力してください。例 0101")
If StrPtr(NewSheetName) = 0 Then
MsgBox "キャンセルします", vbInformation
Exit Sub
ElseIf NewSheetName = "" Then
MsgBox "未入力です", vbExclamation
Exit Sub
End If
For Each c In Worksheets
If c.Name = NewSheetName Then
MatchFLG = True
MsgBox ("既に、同名の シートがあり再度入力して下さい。"), vbExclamation
Exit For
End If
Next
Loop Until MatchFLG = False
End Sub

２
私なりにご回答を編集追加したところ、
シートはコピーされ　同名のシート名は「既に、同名の シートがあり再度入力して下さい。」
までは上手くできました。
ただしその後は下記のようなコーションが出ました。
解決策を再度ご指導いただけませんでしょうか。

「実行時エラー’1004’
シートの名前をほかのシート、Visual Basic で参照されるオブジェクト　ライブラリまたはワークシートと同じ名前に変更することはできません。」

デバックで　「.Name = NewSheetName」　黄色で反転しています。

Private Sub CommandButton1_Click()

'2014/10/15 YOKOHAMA CHABIN

Dim NewSheetName As String

NewSheetName = InputBox("一桁の月及び日でも二桁のMMDD形式で新しいシート名を入力してください。例 0101")

If StrPtr(NewSheetName) = 0 Then
MsgBox "キャンセルします", vbInformation
Exit Sub
ElseIf NewSheetName = "" Then
MsgBox "未入力です", vbExclamation
Exit Sub
End If
For Each c In Worksheets
If c.Name = NewSheetName Then
MatchFLG = True
MsgBox ("既に、同名の シートがあり再度入力して下さい。"), vbExclamation
Exit For
End If
Next

Sheets("元本").Copy After:=Sheets("元本")
With ActiveSheet
.Name = NewSheetName
With .Range("A1")
.NumberFormatLocal = "0000"
.Value = NewSheetName
End With
.OLEObjects("CommandButton1").Delete
.Range("A2").Select
End With
Sheets("元本").Activate
Application.ScreenUpdating = True

End Sub

回答No.1

kkkkkm

以下のような感じでいかがでよう。未入力とキャンセルでは処理を中断します。

Dim NewSheetName As String
Dim c As Object
Dim MatchFLG As Boolean

Do
MatchFLG = False
NewSheetName = InputBox("一桁の月及び日でも二桁のMMDD形式で新しいシート名を入力してください。例 0101")
If StrPtr(NewSheetName) = 0 Then
MsgBox "キャンセルします", vbInformation
Exit Sub
ElseIf NewSheetName = "" Then
MsgBox "未入力です", vbExclamation
Exit Sub
End If
For Each c In Worksheets
If c.Name = NewSheetName Then
MatchFLG = True
MsgBox ("既に、同名の シートがあり再度入力して下さい。"), vbExclamation
End If
Next
Loop Until MatchFLG = False

以下に新規作成のコード