Option Explicit
' A1セルを参照する定数(シート名のもとになるセル)
Private Const NAME_REFERENCE As String = "A1"
' シート名で使えない文字を置換するときの置き換え文字
Private Const REPLACE_CHAR As String = "_"
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' 変更されたセルが A1 の範囲と交差するかをチェック
If Not Intersect(Target, Sh.Range(NAME_REFERENCE)) Is Nothing Then
Dim newName As String
' A1の値をシート名として整形（無効文字置換や長さ制限など）
newName = ReplaceInvalidChars(CStr(Target.Value))
On Error GoTo err_handler
' 実際にシート名を変更
Sh.Name = newName
On Error GoTo 0
End If
Exit Sub
err_handler:
Select Case Err.Number
Case 1004 ' 既に存在するシート名、もしくは無効文字など
MsgBox "シート名を「" & newName & "」に変更できませんでした。" & vbCrLf & _
"既に存在する名前か、無効な名前の可能性があります。"
Case Else
MsgBox "シート名の変更で予期せぬエラーが発生しました。番号: " & Err.Number & vbCrLf & _
"内容: " & Err.Description
End Select
End Sub
Private Function ReplaceInvalidChars(sheetName As String) As String
' Excelで無効な文字 + ダブルクォート
Dim invalidChars As Variant
invalidChars = Array(":", "\", "?", "[", "]", "/", "*", """")
Dim i As Long
For i = LBound(invalidChars) To UBound(invalidChars)
sheetName = Replace(sheetName, invalidChars(i), REPLACE_CHAR)
Next i
' 改行やタブを除去したい場合
sheetName = Replace(sheetName, vbCr, "")
sheetName = Replace(sheetName, vbLf, "")
sheetName = Replace(sheetName, vbTab, "")
' Excelシート名は31文字までなので、それを超える場合は切り捨てる
If Len(sheetName) > 31 Then
sheetName = Left(sheetName, 31)
End If
' 空白文字のみのケースを防ぐ
If Trim(sheetName) = "" Then
' 空にならないように、日時付きのシート名を付与
sheetName = "シート" & Format(Now, "yyyymmddHHMMSS")
End If
ReplaceInvalidChars = sheetName
End Function
コメント