【VBA】シート名が重複したら連番になるワークシートの新規作成

VBAを設計していると、ワークシートを新規作成させたくなることは多々あります。
当然、ワークシートを新規作成した際に名前が重複しているとエラーを引き起こしてしまいます。これはExcelの仕様上の問題です*1。

だからと言いて、わざわざワークシート名が被らないように気を遣うのもメンドクサイものです。
そこでワークシート名が重複した際は自動的に連番になるようなVBAを作成しました。
取り敢えず以下のコードを全部コピペして、プロシージャ「WS」実行すれば動くはずです。

例えば"Sheet1"を作成したいときすでに"Sheet1"があれば、"Sheet1(1)"を生成します。
"Sheet1", "Sheet1(1)"がある場合は"Sheet1(2)"と連番が続きます。
戻り値は生成したシート名になります。

***追記2018.5/25

連番の機能は問題なく動作するようですが、シート名が重複する時の例外処理が不十分なようです。
Excelでは英字の半角全角や日本語の平仮名カタカナ半角全角では全て同じ文字列と認識するようなので、これらの処理が必要になります。
このプログラムでは半角全角カナが混在しているような場合にはエラーになるっぽいです。いずれ直しておきます。

***追記2018.5/31

最新記事を更新しました。最新のコードは以下を参照してください。
tanisukestr.hatenablog.com

***※2018/11/10追記

この記事が参考になったか、記事下のアンケートにご協力ください

'WorkSheet名を与えることでワークシートを新規作成
'重複したworksheetがある場合、(1), (2), ...と連番になる。
'呼び出し側には作成したワークシート名(ByRef)を返す。
Sub CreateNewWorksheet(ByRef SheetName As String)
    
    Dim i As Long, j As Long
    Dim rc As String, tmpSN As String
    Dim NewMode As Boolean
    Dim CworkS As Boolean 'Loopの終了判定(Checkworksheet)
    CworkS = True
    tmpSN = SheetName

        '新しいグラフ描画用シートの作成
        Do While CworkS
            CworkS = WorkSheetCheck(tmpSN)
                '重複したworksheetがある場合、(1), (2), ...と連番をつけて,
                '更に重複が無いか調べてない場合はWorksheet名として適用する。
                j = j + 1 '連番用の変数
    
                If CworkS Then
                    '重複した場合
                    If j = 1 Then
                        rc = MsgBox(SheetName & vbCrLf & "はすでに開いています" & vbCrLf & "新しく読み込みますか?", _
                        vbExclamation + vbYesNo)
                    End If
                    
                    If rc = vbYes Then
                        'worksheet新規作成モードに切り替え
                        NewMode = True
                        'シート名の再設定
                        tmpSN = SheetName & "(" & j & ")"
                    Else
                        MsgBox "終了します"
                        Exit Sub
                    End If
                End If
            
        Loop
        
        'ワークシートを最後尾に新規作成し、指定したファイル名にする。
        If NewMode Then
            With Worksheets.Add(after:=Worksheets(Worksheets.Count))
                .Name = tmpSN
                SheetName = tmpSN
            End With
        Else
            With Worksheets.Add(after:=Worksheets(Worksheets.Count))
                .Name = SheetName
            End With
        End If

End Sub


'重複したWorksheetが有るかチェックする。
'引数;検索するシート名 CheckSheets
'戻り値; 重複検出=>WSC=True, 重複なし=>WSC=False
Function WorkSheetCheck(ByVal CheckSheets) As Boolean
    Dim i As Long
    WorkSheetCheck = False
    Dim a As String
    
    For i = 1 To Worksheets.Count
        a = Worksheets(i).Name
        If Worksheets(i).Name = CheckSheets Then
            WorkSheetCheck = True
            Exit Function
        End If
    Next
    
End Function

これを実際に使用する際は、以下のプロシージャを実行すればOKです。

Sub WS()
    Dim test As String
    test = "sheet1" '新規作成したいワークシート名を書きます。
    Call CreateNewWorksheet(test)
    
    Debug.Print test
End Sub

*1:VBAを扱っているとその道理も理解できることでしょう。