Excelのマクロでシートを追加する際のエラー対策

質問

久しぶりにExcelのマクロについて
質問させていただきます。

Sub シート追加()
Dim シート名 As String, シート確認 As Worksheet
シート名 = InputBox("シート名を入力してください")
For Each シート確認 In Worksheets
If シート確認.Name = シート名 Then
MsgBox "同じ名前のシートがあります", vbCritical
Call シート追加
End If
Next
ActiveSheet.Copy before:=ActiveSheet
ActiveSheet.Name = シート名
End Sub

作ったマクロをごくシンプルにして
記載させていただきました。
これにより、シート名を付けて
次々とシートを追加しているのです。

問題は、すでに同じ名前のシートがあった場合です。
うっかり同じ名前を入力しても
「同じ名前のシートがあります」と表示され
「OK」を押すと改めて
「シート名を入力してください」
と表示されるようにしました。
しかし、なぜかこの場合
新たに入力したシート名でシートが作られるだけでなく
そのシート名に「(2)」が付いたシートまで作られ

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

というエラーが表示されてしまうのです。
Excel2010でもExcel2003でも同じでした。

ステップインでたどってみたのですが
「同じ名前のシートがあります」
が表示された場合
まだ使っていない名前のシートを作っても
黄色いままで「End Sub」から「End If」へ移ってしまいます。
ちなみに 「同じ名前のシートがあります」にならなければ
「End If」で終了したことになり
黄色は消えます。

詳しい方にはごく簡単なことなのでしょうが
いろいろ検索しても答えは得られませんでした。
ご回答をよろしくお願いいたします。

回答No.3

WindFaller · ベストアンサー

こんにちは。

> If シート確認.Name = シート名 Then
これは、まずいですね。TextCompare モードにしないと、いけません。
簡単なことではあっても、最初は、教わらないと分からない点がいくつかあります。
すぐに思いつくというものではありませんね。同名シートを探す方法は、On Error Resumne で、数式を入れてエラーが出れば、OKという方法もあります。

他にも、Like 演算子を使ってもよいのですが、そうすると、Option Compare Textにしなければなりませんが、ふつうは、StrComp関数を用います。一応、シート名チェックには、おまけも付けました。

'//
Sub SheetAdd()
　Dim ShName As Variant
　Dim msg As String
　Do
　　ShName = Application.InputBox("シート名を入力してください" & vbCr & msg, "シート名追加", Type:=2)
　　If VarType(ShName) = vbBoolean Or ShName = "" Then Exit Sub
　　msg = "'" & ShName & "'" & "そのシート名を適さないようです。"
　Loop Until IsSheetName(ShName)
　ActiveSheet.Copy Before:=ActiveSheet
　ActiveSheet.Name = ShName
End Sub

Private Function IsSheetName(ShName As Variant) As Boolean
'シート名のエラーチェック
　　Dim v As Variant
　　Dim i As Integer
　　Dim sh As Object
　　'文字列の長さの制限
　　If Len(ShName) > 31 Then IsSheetName = False: Exit Function
　　'使用出来ない文字の検出
　　For Each v In Array(":", "\", "/", "?", "*", "(", ")")
　　　　i = InStr(1, ShName, v, vbBinaryCompare)
　　　　If i > 0 Then IsSheetName = False: Exit Function
　　Next v
　　For Each sh In ActiveWorkbook.Sheets
　　　 If StrComp(sh.Name, ShName, vbTextCompare) = 0 Then IsSheetName = False: Exit Function
　　 Next sh
　　IsSheetName = True
End Function
'//

お礼

回答、ありがとうございました。

早速コピーして試させていただいたところ
希望していたとおりの操作ができました。
使用できない文字のチェックまで付けていただき
大変分かりやすかったです。

おっしゃるとおり
マクロの世界には
詳しい人から教わらないと一歩も先へ進めないことが
たくさんあるのですね。

また何かありましたら
ぜひご指導いただければと思っております。
今後ともよろしくお願いいたします。

回答No.2

mitarashi

なかなか大胆な「再帰」の使い方で、小改造ではどうにも出来ませんでした。
動作を下記の様なコードで試してみました。
Dim level As Long

Sub シート追加()
Dim シート名 As String, シート確認 As Worksheet

Debug.Print "level:", level
シート名 = InputBox("シート名を入力してください")
For Each シート確認 In Worksheets
If シート確認.Name = シート名 Then
MsgBox "同じ名前のシートがあります", vbCritical
level = level + 1
Call シート追加
level = level - 1
End If
Next
' ActiveSheet.Copy before:=ActiveSheet
' ActiveSheet.Name = シート名 'エラーになってしまうのでコメントアウト
Debug.Print "ActiveSheet.Name = ", シート名
DoEvents: DoEvents: DoEvents
End Sub

☆動作結果 既存のSheet1を3回Input後、新しいSheet4をInputしました。
level: 0
level: 1
level: 2
level: 3
ActiveSheet.Name = Sheet4
ActiveSheet.Name = Sheet1
ActiveSheet.Name = Sheet1
ActiveSheet.Name = Sheet1

既存の名前を入力する毎に、深いレベルに潜って行き、新しい名前を入力すると、順次戻ってきますが、コードの後半の部分が都度実行されます。
コメントアウトの部分を生かすと、最初にActiveSheetがコピーされてSheet4と改名され、その次にSheet4が一旦コピーされてSheet4(2)が生成した後、Sheet1に改名しようとして名前重複のエラーが発生して止まる事になります。

時間が無いので、突っ込みどころ満載とは思いますが、改善策の一例です。
キャンセル対策等、Office TANAKAのサイトがご参考になります。
Sub シート追加2()
Dim シート名 As String, シート確認 As Worksheet
Do
シート名 = InputBox("シート名を入力してください")
Loop Until sheetExistCheck(シート名)
ActiveSheet.Copy before:=ActiveSheet
ActiveSheet.Name = シート名
End Sub

Function sheetExistCheck(newSheetName As String) As Boolean
Dim シート確認 As Worksheet
For Each シート確認 In Worksheets
If シート確認.Name = newSheetName Then
MsgBox "同じ名前のシートがあります", vbCritical
sheetExistCheck = False
Exit Function
End If
Next
sheetExistCheck = True
End Function

なお、既存のSheet1に対して、小文字のsheet1をInputすると、同名チェックはくぐり抜けた後で、改名の時にエラーとなる事を発見しました。ご参考まで。

お礼

詳しい回答をくださり
ありがとうございました。

早速試してみたところ
無事に動作の確認が取れました。
最後に補足してくださっている
小文字のsheet1の件についても
おっしゃるとおりの反応でした。
うっかりしないように気を付けます。
本当にありがとうございました。

また何かありましたら
よろしくお願いいたします。

回答No.1

bin-chan

> MsgBox "同じ名前のシートがあります", vbCritical
> Call シート追加
の２行の間に Elseが足りない

MsgBox "同じ名前のシートがあります", vbCritical
ELSE
Call シート追加

もっと言うと
MsgBox "同じ名前のシートがあります", vbCritical
Exit For
Else
Call シート追加

お礼

回答、ありがとうございます。
早速試してみたのですが
どのような名前を入れても
「シート名を入力してください」が表示されるだけで
先へ進めなくなってしまいました。
何が原因なのでしょうか。