トップ　>　汎用コード　>　アクティブブックのシート名を一括変更

'----------------------------------------------------------------------------------
' アクティブブックのワークシート名を一括変更
'----------------------------------------------------------------------------------
' アクティブブックのワークシート名を［基準名］+［(3桁) 連番］に設定するマクロです
' シートの見出しに色がついていないものを変更対象とします
' ワークシート数が999を超えるブックには対応していません
' シート名の文字数制限の関係で基準名は最大28文字までとなります
'［作成日］2023/05/24　［更新日］2023/05/25
' https://excel.syogyoumujou.com/vba/rename_worksheets.html
'----------------------------------------------------------------------------------
Sub RenameActivebookWorksheets()

    Const CNAME As String = "サンプル" '基準名
    
    Dim strErrorMessage As String
    
    'ブックの保護の確認
    If ActiveWorkbook.ProtectWindows Then
        strErrorMessage = "ブックが保護されています"
        GoTo ERROR_HANDLER
    End If

    '基準名の文字数確認
    If 28 < Len(CNAME) Then
        strErrorMessage = "基準名が長すぎます (最大28文字)"
        GoTo ERROR_HANDLER
    End If
    
    'ワークシート名を配列に格納
    Dim i               As Long
    Dim c               As Long
    Dim strSheetsName() As String
    With ActiveWorkbook
        For i = 1 To .Worksheets.Count
            ReDim Preserve strSheetsName(c)
            strSheetsName(c) = .Worksheets(i).Name
            c = c + 1
        Next
    End With
    If c = 0 Then
        strErrorMessage = "ワークシートがありません"
        GoTo ERROR_HANDLER
    ElseIf 999 < c Then
        strErrorMessage = "ワークシートが多すぎます"
        GoTo ERROR_HANDLER
    End If

    '新しい名前の作成　［基準名］+［(3桁)連番］
    ReDim strNewSheetsName(0 To c - 1) As String
    For i = 0 To c - 1
        strNewSheetsName(i) = CNAME & Format$(i + 1, "000")
    Next
    
    On Error GoTo ERROR_HANDLER
    
    '現在のシート名と新しい名前の重複確認
    Dim varMatch    As Variant
    Dim strRndName  As String
    Dim varMatchRnd As Variant
    For i = 0 To c - 1
        varMatch = Application.Match(strNewSheetsName(i), strSheetsName, 0)
        '名前が重複していた場合には、仮のシート名を設定
        If Not IsError(varMatch) Then
            With ActiveWorkbook.Worksheets(strSheetsName(varMatch - 1))
                Do
                    strRndName = Left$(.Name, 26) & "_" & WorksheetFunction.RandBetween(1, 1000)
                    varMatchRnd = Application.Match(strRndName, strSheetsName, 0)
                Loop Until IsError(varMatchRnd)
                .Name = strRndName
            End With
            strSheetsName(varMatch - 1) = strRndName
        End If
    Next
    
    'シートに新しい名前を設定
    Application.ScreenUpdating = False
    Dim lngCount As Long
    For i = 0 To c - 1
        With ActiveWorkbook.Worksheets(strSheetsName(i))
            'タブに色がついていないシートのみ連番を設定する
            If .Tab.ColorIndex = xlNone Then
                .Name = strNewSheetsName(lngCount)
                lngCount = lngCount + 1
            End If
        End With
    Next
    Application.ScreenUpdating = True
    
    On Error GoTo 0
Exit Sub
ERROR_HANDLER:
    If Err.Number <> 0 Then
        strErrorMessage = "エラー番号：" & Err.Number & vbLf
        strErrorMessage = Err.Description
    End If
    MsgBox strErrorMessage, vbExclamation, "終了します"
End Sub