チェックボックス（フォームコントロール）のグループ番号を更新する

昨日は、選択したチェックボックス（フォームコントロール）の名前を変更することに挑戦した。
infoment.hatenablog.com

今日は、グループ番号の更新に挑戦する。
f:id:Infoment:20191118223135p:plain

今までの方式の場合、新たなグループを作成するごとに、グループ番号の「最大値＋１」を新規グループ番号としていた。

例えば、３つのグループがあるとする。

グループ１
グループ２
グループ３

このグループ１とグループ２を統合すると、このようになる。

グループ３
グループ４（＝旧グループ１＋旧グループ２）

グループ番号の１と２は、欠番となる訳だ。

これだとグループ更新のたびに、ツルツルとウナギのように、グループ番号が上に登って行ってしまう（例えが古い？）。

そこでグループ作成毎に、グループ番号を更新してみた。

ユーザーフォーム（CBsEditForm）

Private Sub UpdateGroupNumber()
    ' 既存の全グループ番号を取得するための辞書。
    ' 同時に重複削除を行うために、辞書を用いている。
    Dim TempDict As Object
    Set TempDict = CreateObject("Scripting.Dictionary")
    Dim CB As CheckBox
        ' グループ番号を持たないチェックボックスは、
        ' 「CB_グループ番号_グループ名」
        ' となっていない。今回は単純に、エラー無視で対応。
        On Error Resume Next
        For Each CB In CBs
            TempDict(Split(CB.Name, "_")(1)) = 1
        Next
        On Error GoTo 0
        
        ' 一旦取得したグループ番号（辞書のキー情報）を配列に
        ' 渡し、当該配列を昇順ソート。
    Dim arr As Variant
        arr = TempDict.keys
        arr = SortArray(arr)
    
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim i As Long
        ' 配列の値をキーに、キーの登場順をアイテムに持つ
        ' 辞書を作成。これにより、各グループ番号が、グループ内で
        ' 何番目に小さいかがわかる。
        For i = 0 To UBound(arr)
            Dict(CLng(arr(i))) = i + 1
        Next
    
        ' 各グループ番号を更新。
    Dim TempArray As Variant
        For Each CB In CBs
            TempArray = Split(CB.Name, "_")
            If UBound(TempArray) > 0 Then
                TempArray(1) = Dict(CLng(TempArray(1)))
                CB.Name = Join(TempArray, "_")
            End If
        Next
End Sub

上記を、グループ作成のタイミングで実行する。

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
        
        ' グループ番号更新（上記で発生した可能性のある欠番を解消）。
        UpdateGroupNumber ' <---------------ここ
        
        ' リストボックス更新。
        ResetCBsListBox
End Sub