VBAで入力規則を設定する

VBAで入力規則を設定しようと、Edgeブラウザの標準のcopilotに聞いても間違えていたので、調べてみました。

お使いください。

Option Explicit

' メイン処理: 入力規則（○,△,×）を設定する
Public Sub メイン_入力規則設定()
    
    Dim ws_対象シート As Worksheet
    Dim rng_開始セル As Range
    Dim rng_終了セル As Range
    Dim rng_対象範囲 As Range
    Dim str_リスト内容 As String
    
    Dim lng_最終行 As Long
    Dim lng_最終列 As Long
    
    ' 対象シートの設定
    Set ws_対象シート = ActiveSheet
    
    ' ▼ 開始セルの設定 (どちらか一方を有効にしてください)
    
    ' パターン1: "A列" のデータ最終行を開始セルにする
    Const STR_基準列 As String = "A" ' ← ★基準にする列
    Set rng_開始セル = func_列最終セル取得(ws_対象シート, STR_基準列)
    ' 基準列が空ならA1セルをセット
    If rng_開始セル Is Nothing Then Set rng_開始セル = ws_対象シート.Range("A1")
    
    ' パターン2: "B5" など特定のセルを開始セルにする
    'Const STR_開始セル番地 As String = "B5" ' ← ★開始セルの番地
    'Set rng_開始セル = ws_対象シート.Range(STR_開始セル番地)
    
    ' ▼ 終了セルの設定
    
    On Error Resume Next ' データが無い場合にFindがエラーになるため
    ' データのある最終行を取得 (値または数式)
    lng_最終行 = ws_対象シート.Cells.Find(What:="*", _
                                    LookIn:=xlFormulas, _
                                    SearchOrder:=xlByRows, _
                                    SearchDirection:=xlPrevious).Row
    
    ' データのある最終列を取得 (値または数式)
    lng_最終列 = ws_対象シート.Cells.Find(What:="*", _
                                    LookIn:=xlFormulas, _
                                    SearchOrder:=xlByColumns, _
                                    SearchDirection:=xlPrevious).Column
    On Error GoTo 0
    
    ' データが全くない場合
    If lng_最終行 = 0 Or lng_最終列 = 0 Then
        ' 開始セルを終了セルとする (範囲が開始セルのみになる)
        Set rng_終了セル = rng_開始セル
    Else
        ' 最終行、(最終列 + 5) を終了セルとする
        Set rng_終了セル = ws_対象シート.Cells(lng_最終行, lng_最終列 + 5)
    End If
    
    ' ▼ 入力規則の設定
    Set rng_対象範囲 = ws_対象シート.Range(rng_開始セル, rng_終了セル)
    str_リスト内容 = "○,△,×"
    
    ' 既存の規則をクリア
    rng_対象範囲.Validation.Delete
    
    ' リスト形式の規則を追加
    rng_対象範囲.Validation.Add _
        Type:=xlValidateList, _
        AlertStyle:=xlValidAlertStop, _
        Operator:=xlBetween, _
        Formula1:=str_リスト内容
    rng_対象範囲.Validation.InCellDropdown = True

    MsgBox "入力規則を設定しました。 (範囲: " & rng_対象範囲.Address & ")"
           
End Sub

' 補助Function: 指定した列のデータが入っている最後のセルを取得
Private Function func_列最終セル取得(ByVal ws_対象シート As Worksheet, ByVal str_列文字 As String) As Range
    Dim lng_最終行 As Long
    
    lng_最終行 = ws_対象シート.Cells(ws_対象シート.Rows.Count, str_列文字).End(xlUp).Row
    
    ' 1行目にもデータがない場合 (列が空)
    If lng_最終行 = 1 And ws_対象シート.Cells(1, str_列文字).Value = "" Then
        Set func_列最終セル取得 = Nothing
    Else
        Set func_列最終セル取得 = ws_対象シート.Cells(lng_最終行, str_列文字)
    End If
End Function