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

'***************************************************************
'* アクティブブックのワークシート名を一括変更する
'*--------------------------------------------------------------
'* 概要     | アクティブブックのワークシート名を
'*          | ［基準名］+［3桁連番］に一括変更する
'*          | タブに色がついていないシートのみを変更対象とする
'*          | ※ワークシート数が999を超えるブックには対応していない
'*          | ※シート名の文字数制限により基準名は最大28文字まで
'*          | 参考：https://excel.syogyoumujou.com/vba/rename_worksheets.html
'* 引数     | なし
'* 戻り値   | なし
'* 作成日   | 2023.05.24
'*--------------------------------------------------------------
'* 改修履歴 | 2026.04.05
'***************************************************************
Public Sub renameActiveWorkbookSheets()

On Error GoTo LBL_ERROR

    '------------------------------
    ' 定数定義
    '------------------------------
    Const BASE_NAME As String = "サンプル" ' 基準名

    '------------------------------
    ' 処理実行前確認
    '------------------------------
    Dim strErrorMessage As String
    ' ブックが保護されている場合は終了
    If ActiveWorkbook.ProtectWindows Then
        strErrorMessage = "ブックが保護されています"
        GoTo LBL_ERROR
    End If

    ' 基準名の文字数確認
    If 28 < Len(BASE_NAME) Then
        strErrorMessage = "基準名が長すぎます (最大28文字)"
        GoTo LBL_ERROR
    End If

    '------------------------------
    ' ワークシート名を配列に格納
    '------------------------------
    Dim i               As Long
    Dim lngCount        As Long
    Dim strSheetsName() As String

    With ActiveWorkbook
        For i = 1 To .Worksheets.Count
            ReDim Preserve strSheetsName(lngCount)
            strSheetsName(lngCount) = .Worksheets(i).Name
            lngCount = lngCount + 1
        Next i
    End With

    If lngCount = 0 Then
        strErrorMessage = "ワークシートがありません"
        GoTo LBL_ERROR
    ElseIf 999 < lngCount Then
        strErrorMessage = "ワークシートが多すぎます"
        GoTo LBL_ERROR
    End If

    '------------------------------
    ' 新しいシート名の生成
    '------------------------------
    ' ［基準名］+［3桁連番］の形式で新しい名前を生成
    Dim strNewSheetsName() As String
    ReDim strNewSheetsName(0 To lngCount - 1)
    For i = 0 To lngCount - 1
        strNewSheetsName(i) = BASE_NAME & Format$(i + 1, "000")
    Next i

    '------------------------------
    ' シート名の重複確認と仮名設定
    '------------------------------
    ' 新しい名前が既存のシート名と重複する場合は仮のシート名を設定
    Dim varMatch    As Variant
    Dim varMatchRnd As Variant
    Dim strRndName  As String
    Dim strWshName  As String
    Dim wsh         As Worksheet

    For i = 0 To lngCount - 1
        varMatch = Application.Match(strNewSheetsName(i), strSheetsName, 0)
        If Not IsError(varMatch) Then
            Set wsh = ActiveWorkbook.Worksheets(strSheetsName(varMatch - 1))
            strWshName = Left$(wsh.Name, 26) & "_"
            Do
                strRndName = strWshName & WorksheetFunction.RandBetween(1, 1000)
                varMatchRnd = Application.Match(strRndName, strSheetsName, 0)
            Loop Until IsError(varMatchRnd)
            wsh.Name = strRndName
            strSheetsName(varMatch - 1) = strRndName
        End If
    Next i

    '------------------------------
    ' 新しいシート名の設定
    '------------------------------
    ' タブに色がついていないシートのみ連番を設定する
    Application.ScreenUpdating = False

    Dim lngRenameCount As Long
    For i = 0 To lngCount - 1
        Set wsh = ActiveWorkbook.Worksheets(strSheetsName(i))
        If wsh.Tab.ColorIndex = xlNone Then
            wsh.Name = strNewSheetsName(lngRenameCount)
            lngRenameCount = lngRenameCount + 1
        End If
    Next i

    Application.ScreenUpdating = True
    Exit Sub

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then
        strErrorMessage = "エラー番号：" & Err.Number & vbLf & Err.Description
    End If
    MsgBox strErrorMessage, vbExclamation, "終了します"
End Sub