(VBA)Excelシートの追加時、重複しないよう追番を付ける

Excel ブックに新しくシート挿入して、任意の名前に変更するとき、重複していれば、追番を付けてシート名の重複を防ぎます。

以下の例では、追加シート名に「更新履歴」を付けたい場合、その名前が既に使われていないか確認し、使っていればシート名に追番を付与し、エラーが出ないようにする。

ブックの追加は行いません。名前の確認のみ。

どんなときに使うかというと、シートを追加して、シート名を「その日の日付」にする場合、同じ日に実行すると、シート名が重複してしまいます。そのため、日付に追番(1,2・・・)を付けて、シート名が重複しないようにします。

以下の「Sub シート名決定」 を実行すると、関数[追加シートの名前]を呼び出し、重複しないシート名を作成します。

'関数呼び出し

Sub シート名決定()

    Dim tgtBook As Workbook 'シートを追加したいブック
    Set tgtBook = ThisWorkbook
    Debug.Print tgtBook.Name
    
    Dim stName As String    '新規に追加するシート名(可能か確認したい)
    stName = "更新履歴"
    
    Dim newName As String
    newName = 追加シートの名前(tgtBook, stName) '関数呼び出し
    
    MsgBox "追加シートの名前は : " & newName

End Sub


'◆===================================================

Function 追加シートの名前(tgtBook As Workbook, stName As String) As String

    'Dim tgtBook As Workbook
    'Dim stName As String    '新規に追加するシート名
    'stName = "更新履歴"
    Dim stName2 As String    '重複確認用シート名
    stName2 = stName
    Dim i As Integer    'for-next カウンタ
    Dim j As Integer    'シート名重複防止用追番
    j = 0
    Dim NG As Byte
    Dim OK As Byte

    Dim doCnt As Integer 'Do-Loopカウンタ(無限ループ予防)
    doCnt = 0
    Do While OK = 0
        NG = 0
        OK = 0
        For i = 1 To tgtBook.Worksheets.Count
            Debug.Print "doCnt:"; doCnt, "i:"; i, "NG:;"; NG, "OK:"; OK, stName2, Sheets(i).Name
            If tgtBook.Sheets(i).Name = stName2 Then
                '追番追加
                j = j + 1
                stName2 = stName & "(" & CStr(j) & ")"
                NG = 1
                Exit For
            End If
        Next i

        If NG = 0 Then
            OK = 1
        End If
        
    doCnt = doCnt + 1
    If doCnt > 1000 Then Exit Do
    Loop
    Debug.Print "新規シート名決定= "; stName2
    
    追加シートの名前 = stName2

End Function

上記のコードは、重複しないシート名の生成までなので、このあと、実際にシートを追加し、上記で得られたシート名に変更します。