VBAノック46本目：名前定義に使える文字 - 和風スパゲティのレシピ

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：名前定義に使える文字
ソースコード
- メインモジュール
- 汎用関数モジュール
解説

出題：名前定義に使える文字

#VBA100本ノック 46本目
1行目の見出しをそのセルの名前定義(ブック範囲)に設定してください。
・記号や空白は"_"に置換
・先頭使用不可文字の場合は先頭に"_"を補う
エラー回避できない場合はイミディエイトに出力
※見出しは重複しないように入力
※既存の名前定義は無視して良い
※シートは任意

見出しを名前定義

◇ 出題ページはこちら

ソースコード

メインモジュール

Option Explicit

' 100本ノック046：名前定義に使える文字
Sub データ見出しを名前定義する()
    
    Dim ws対象シート As Worksheet: Set ws対象シート = ActiveSheet
    
    ' 値のある見出しセルをループ
    Dim C As Long
    Dim isエラーあり As Boolean: isエラーあり = False
    For C = 1 To Get最終列(ws対象シート)
        
        Dim 対象セル As Range: Set 対象セル = ws対象シート.Cells(1, C)
        If 対象セル.Value <> "" Then
        
            ' 記号を「_」に置換
            Dim 設定名称 As String
            設定名称 = Replace記号→_(対象セル.Value)
            
            ' 名前を設定し、エラーなら先頭に"_"をつけてもう一度試す
            On Error Resume Next
            対象セル.Name = 設定名称
            If Err.Number > 0 Then
                Err.Clear
                対象セル.Name = "_" & 設定名称
            End If
            
            ' それでもエラーならイミディエイトに表示
            If Err.Number > 0 Then
                isエラーあり = True
                Debug.Print 対象セル.Address(0, 0) & "セルでエラー：" & Err.Description
            End If
            
            On Error GoTo 0
            
        End If
    Next
        
    If isエラーあり Then MsgBox "名前定義に登録できない名前がありました。（詳細はイミディエイトウィンドウに表示）"

End Sub

' 記号をアンダーバーに置換
Function Replace記号→_(ByVal 元文字列 As String) As String
    
    Dim 結果値 As String
    
    Const 半角記号集 = " !""#$%&'()*+,-./:;<=>?@[\]^`{|}~"
    Dim 全角記号集 As String: 全角記号集 = StrConv(半角記号集, vbWide)
    Dim 判定記号集 As String: 判定記号集 = 半角記号集 & 全角記号集
    
    結果値 = Fx.Clean(元文字列)
    
    Dim n As Long
    For n = 1 To Len(元文字列)
        Dim 第n文字 As String: 第n文字 = Mid(元文字列, n, 1)
        
        If InStr(判定記号集, 第n文字) > 0 Then Mid(結果値, n, 1) = "_"
        
    Next
    
    Replace記号→_ = 結果値

End Function

汎用関数モジュール

Option Explicit

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 最終列の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終列(指定オブジェクト As Variant, Optional ByVal R As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終列を取得
    Get最終列 = 対象セル範囲.Columns.Count + 対象セル範囲.Column - 1

    ' 列が指定されていればその列の入力最終行を取得
    If R <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(R, Get最終列) = ""
            Get最終列 = Get最終列 - 1
            If Get最終列 < 対象セル範囲.Column Then
                Get最終列 = 0
                Exit Function
            End If
        Loop
    End If

End Function