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

※2018/11/10追記
この記事が参考になったか、記事下のアンケートにご協力ください。

Excelマクロ、VBAでワークシートを作成するときにこのようなエラーが生じた経験はありませんか？
この名前は既に使われています。別の名前を入力してください。
とか
実行時エラー '1004' : アプリケーション定義またはオブジェクト定義のエラーです。
とか。これは新規作成するシート名が既に存在している場合に生じます。

いつだかに、Excelのワークシート名が重複した際に連番をふるVBAを公開しましたが、どうやらエラーの処理が完全ではなかったので修正しました。

本題

Excelの仕様上、アルファベットの半角全角やひらがな、カタカナの全角半角の区別がないようで、”とうかいニッキ”や”ﾄｳｶｲにっき”は同じシート名として判定されるようです。
従ってこれらの例外が生じた際の回避をしなければなりません。
このコードでは英字はすべて全角、ひらがなカタカナは全角に直して全てひらがなに変換することで判定漏れが無いようにしました。

これでよっぽどのことがない限りはエラーが生じないと思います。
ただ、このプログラムが回っているときに、セルの編集をしていると新規Sheetは生成できずにエラーとなります。これはExcelの仕様なのでどうしようもありません。てかマクロを実行しているときにセルの編集はあまりしないほうがいいです。

以下のコードをコピペしてプロシージャ”WS”を実行すればいいです。
実際の実装ではCreateNewWorksheet( String )をCallして使用してください。

Option Explicit

'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 j = 100 Then
                    MsgBox ("カウントが発散してます。")
                    End
                End If
                
                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 tmpShChar As String, tmpChar As String
    
    
    For i = 1 To Worksheets.Count
        'シート名は大文字小文字区別されないのでここで、全て小文字に変換しておく。
        tmpShChar = LCase(Worksheets(i).Name)
        tmpChar = LCase(CheckSheets)
        
        tmpChar = StrConv(tmpChar, vbWide)
        tmpChar = StrConv(tmpChar, vbHiragana)
        tmpShChar = StrConv(tmpShChar, vbWide)
        tmpShChar = StrConv(tmpShChar, vbHiragana)
        
        
        If tmpShChar = tmpChar Then
            WorkSheetCheck = True
            Exit Function
        End If
    Next
    
End Function

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