Excelを快適に使おう

'---------------------------------------------------------------------------------------------------
'
' マクロ: Excelのシート名を取得し、変更したいシート名に変更します
'
' 使い方：�@マクロ「Macro1_getSh」でシート名一覧をA5セル以降に列挙します
'         �AB5セル以降に手打ちで変更したいシート名を記載します
'         �Bマクロ「Macro2_setSh」でシート名を変更します
'---------------------------------------------------------------------------------------------------
Option Explicit

'---------------------------------------------------------------------------------------------------
' 概要：シート名一覧を取得し、A5セル以降に記載
'---------------------------------------------------------------------------------------------------
Sub Macro1_getSh()

    ' マクロ実施時のアクティブなシートに記載すると、間違って上書きする可能性がある
    ' シート内に値がある(履歴も含む)場合、一旦、問い合わせする
    If Cells.SpecialCells(xlCellTypeLastCell).row + Cells.SpecialCells(xlCellTypeLastCell).Column > 2 Then
        Dim rc As Long
        rc = MsgBox("A5セル以降にシート名を列挙します", vbYesNo + vbQuestion)
        If rc <> vbOK And rc <> vbYes Then
            End
        End If
        
        'A5、B5以降のセルの値をクリア
        Range(Cells(5, 1).Address, Cells(Cells.SpecialCells(xlCellTypeLastCell).row, 2).Address).Clear
        
    End If
    
    ' A5セルにヘッダ
    Dim i As Long
    i = 5
    Cells(i, 1) = "【変更前】"
    Cells(i, 2) = "【変更後】"
    i = i + 1
    
    ' シート一覧を取得し、A6セル以降に記載
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
        Cells(i, 1) = ws.Name
        i = i + 1
    Next ws
    
End Sub

'---------------------------------------------------------------------------------------------------
' 概要：変更後シート名一覧を取得し、精査後、シート名変更
'---------------------------------------------------------------------------------------------------
Sub Macro2_setSh()

    ' マクロ手順のチェック
    Dim rng As Variant
    rng = Range(Cells(1, 1).Address, Cells(Cells.SpecialCells(xlCellTypeLastCell).row, 2).Address).Value
    If rng(1, 1) = "【変更前】" And rng(1, 2) = "【変更後】" Then
        MsgBox "マクロ「Macro1_getSh」を実施後、変更後シート名を記載して、マクロ「Macro2_setSh」を実施してください"
        End
    End If
    If UBound(rng) <= 6 Then
        End
    End If
    
    ' Excel制約チェック。下記以外もあるけど、無理して対応するほどでもないと思うので放置
    ' �@同じシート名が複数存在できない
    ' �AExcel95, Excel5.0で、31バイト、全角15文字まで
    ' �B:\?[]/*'は使えない
    Dim i As Long
    Dim j As Long
    For i = 6 To UBound(rng) - 1
        If Len(rng(i, 2)) > 0 Then
        
            '�@
            For j = i + 1 To UBound(rng)
                
                If rng(i, 2) = rng(j, 2) Then
                    MsgBox Cells(i, 2).Address(False, False) & "と" & Cells(j, 2).Address(False, False) & "が同じ文字列です"
                    End
                End If
            Next j
                
            '�A
            If Len(rng(i, 2)) > 15 Then
                MsgBox Cells(i, 2).Address(False, False) & "の文字数が多すぎます(15文字以内)"
                End
            End If
                
            '�B
            If useShWord(CStr(rng(i, 2))) = False Then
                MsgBox Cells(i, 2).Address(False, False) & "はシート名にできません"
                End
            End If
            
        End If
    Next i

    ' シート名を変更
    chgSh rng
    
End Sub


'---------------------------------------------------------------------------------------------------
' 概要：シート名に使用できる文字？
'---------------------------------------------------------------------------------------------------
Private Function useShWord(str As String) As Boolean
    Dim spWd As String
    Dim i As Long
    Dim ret As Boolean
    
    spWd = ":\?[]/*'"

    ret = True
    For i = 1 To Len(spWd)
        If InStr(str, Mid(spWd, i, 1)) > 0 Then
            ret = False
        End If
    Next i

    useShWord = ret
End Function


'---------------------------------------------------------------------------------------------------
' 概要：シート名を変更する
'---------------------------------------------------------------------------------------------------
Private Sub chgSh(rng As Variant)
    On Error GoTo ErrHdl

    
    ' 既存のシート名と重複が無いようにシート名を変更する
    Dim i As Long
    Dim j As Long
    Dim l As Long
    Dim m As Long
    Dim reName As String
    Dim tmpSh() As String
    Dim sameSh As Boolean
    
    ReDim tmpSh(UBound(rng))
            
    l = 1 '変更しないけど仮
    m = 0
    For i = 6 To UBound(rng)
        
        '変更前後が同じなら処理しない
        If rng(i, 1) = rng(i, 2) Then
            rng(i, 2) = ""
        End If
        
        If Len(rng(i, 1)) > 0 And Len(rng(i, 2)) > 0 Then
        
            reName = CStr(rng(i, 2))
            rng(i, 2) = ""
            sameSh = dupSh(reName, rng, tmpSh)
            rng(i, 2) = reName
            
            Do While sameSh
                
                m = m + 1
                reName = l & "(" & m & ")"
                'シート名はExcel95, Excel5.0で、31バイト、全角15文字まで
                If Len(reName) > 15 Then
                    MsgBox "シート名が置換できません"
                    End
                End If
                
                sameSh = dupSh(reName, rng, tmpSh)
                
                If sameSh = False Then
                    tmpSh(i) = reName
                End If
                
            Loop
            
        End If
    Next i

    'シート名一時変更(重複あり)
    For i = 6 To UBound(rng)
        If Len(rng(i, 1)) > 0 And Len(rng(i, 2)) > 0 Then
            If tmpSh(i) <> "" Then
                Worksheets(rng(i, 1)).Name = tmpSh(i)
            End If
        End If
    Next i
    

    'シート名変更
    For i = 6 To UBound(rng)
        If Len(rng(i, 1)) > 0 And Len(rng(i, 2)) > 0 Then
            If tmpSh(i) = "" Then
                Worksheets(rng(i, 1)).Name = CStr(rng(i, 2))
            Else
                Worksheets(tmpSh(i)).Name = CStr(rng(i, 2))
            End If
        End If
    Next i

    Exit Sub

ErrHdl:
    MsgBox "(" & Err.Number & ")" & Err.Description & ":シート名を変更できません"

End Sub

'---------------------------------------------------------------------------------------------------
' 概要：シート名の重複
'---------------------------------------------------------------------------------------------------
Private Function dupSh(str As String, rng As Variant, tmpSh() As String) As Boolean
    Dim i As Long
    Dim ret As Boolean
    
    ret = False
    For i = 6 To UBound(rng)
        
        If str = CStr(rng(i, 1)) Then
            ret = True
            Exit For
        End If
        
        If str = CStr(rng(i, 2)) Then
            ret = True
            Exit For
        End If
        
        If str = CStr(tmpSh(i)) Then
            ret = True
            Exit For
        End If
    
    Next i
    
    dupSh = ret
End Function