指定したCheckBox（フォームコントロール）でグループを作成し、一つしか選択できないようにする。

昨日は、リストボックスで選択した任意のチェックボックス（フォームコントロール）を削除してみた。
infoment.hatenablog.com

今日は、リストボックスで選択した任意のチェックボックス（フォームコントロール）でグループを作成し、一つしか選択できないようにしてみる。
f:id:Infoment:20191113213433p:plain

といっても、基本的な部分は今までに作り終えている。
まずチェックボックス名について、命名ルールを以下に定める。

CB_グループ番号_名前

名前は任意。今回は単純にキャプションをそのまま充てることにしよう。
先日の作りでは、グループは番号でも名前でも成立するようにしていた。
しかし、番号の方が都合が良いと思い直し、今回はグループ番号とした。

これを成立させるため、標準モジュールに以下を追加。

グループ番号の最大値
チェックボックスの名称変更
チェックボックスのオンオフ制御

標準モジュール

グループ番号の最大値は、ActiveSheet内のチェックボックスを総当たりで確認し、Max関数で求めている。

Public Property Get MaxGroupNumber()
    ' 各チェックボックスのグループ番号格納用配列。
    Dim arr() As Variant
    ReDim arr(1 To CBs.Count)
    Dim i As Long: i = 1
    Dim CB As CheckBox
        ' 名称がRenamedCBのルールに則っていないチェックボックスを
        ' 処理する場合に備え、いったんエラー無視とする。この場合、
        ' エラーがあれば配列にはvbNullStringが格納される。
        On Error Resume Next
        For Each CB In CBs
            arr(i) = CLng(Split(CBs.Item(i).Name, "_")(1))
            i = i + 1
        Next
        On Error GoTo 0
        
        ' 配列の最大値を、グループ番号の最大値として返す。
        MaxGroupNumber = WorksheetFunction.Max(arr)
End Property

「グループ名」だと、つど指定しなければならない。だから、番号とした。

チェックボックスの名称変更は、敢えてユーザー定義関数とした。
理由は以下の二つ。

命名ルールを確実に履行するため。
命名したあとのチェックボックスを戻り値とするため。

Function RenamedCB(check_box As CheckBox, _
                   group_number As Long, _
                   cb_caption As String) As CheckBox

        ' チェックボックスの名称変更。
        ' 変更後のチェックボックスを処理する場合に備え、戻り値を
        ' 名称変更後のチェックボックスとするユーザー定義関数にした。
        check_box.Name = "CB_" & group_number & "_" & cb_caption
        Set RenamedCB = check_box
End Function

最後に、チェックボックスのオンオフ制御。

Sub SetSingleSelect()
    ' 選択したチェックボックス名。
    Dim SelectedCBName As String
    ' 本サブルーチンを呼び出したチェックボックスの名前を格納。
        SelectedCBName = Application.Caller
    
    Dim GroupNumber As Long
        On Error Resume Next
        GroupNumber = CLng(Split(SelectedCBName, "_")(1))
        If Err.Number <> 0 Then Exit Sub
    
    ' 選択したチェックボックスと同じグループ番号であれば、チェックを外す。
    Dim CB As CheckBox
        For Each CB In CBs
            If CB.Name <> Application.Caller Then
                If Split(CB.Name, "_")(1) = GroupNumber Then
                    CB.Value = xlOff
                End If
            End If
        Next
        On Error GoTo 0
End Sub

ユーザーフォーム（CBsEditForm）

ここまで作りこむと、ユーザーフォーム側はシンプルになる。
まず、追加したボタンはこちら。
f:id:Infoment:20191113214923p:plain

名称は単純に「GroupingButton」とした。

Private Sub GroupingButton_Click()
    Dim i As Long
    Dim GroupNumber As Long
        ' グループ番号は、最大グループ番号+1とする。
        ' この時点で、グループ番号の欠番発生不問とする。
        ' ※チェックボックス削除により、欠番発生の可能性あり。
        GroupNumber = MaxGroupNumber + 1
        For i = 0 To CBsListBox.ListCount - 1
            If CBsListBox.Selected(i) Then
                ' リストボックスで選択されたチェックボックスについて、
                ' 順次、名称の変更とマクロの登録を同時に行う。
                RenamedCB CBs.Item(i + 1), GroupNumber, CBsListBox.List(i, 1)
                CBs.Item(i + 1).OnAction = "SetSingleSelect"
            End If
        Next
        ' リストボックス更新。
        ResetCBsListBox
End Sub