チェックボックスまとめ

昨日は、作成したチェックボックスのグループ番号更新に挑戦した。
infoment.hatenablog.com

今日は締めとして、今回シリーズのコードをまとめて紹介する。

最終的に、ユーザーフォームはこのようになった。

番号	種類	オブジェクト名	Caption	備考
①	UserForm	CBsEditForm	CheckBox（フォームコントロール）作成・編集
②	Frame	Frame1	選択セルの文字をCheckBoxに変換	単なる枠。フレームの機能は未使用。
③	CommandButton	SetCheckBoxButton	配　置
④	CheckBox	IgnoreBlankCheck	空白を無視する	初期値：True
⑤	CommandButton	CloseButton	終　了
⑥	Label	Label1	名前
⑦	Label	Label2	キャプション
⑧	ListBox	CBsListBox		ColumnCount：2
⑨	CheckBox	MultiSelectCheck	リストの複数選択可	初期値：False
⑩	Label	Label3	選択CheckBoxのキャプション変更
⑪	TextBox	NewCaptionInputBox
⑫	CommandButton	CaptionChangeButton	変更
⑬	CommandButton	SelectAllButton	全選択
⑭	CommandButton	GroupingButton	選択グループ化
⑮	CommandButton	SelectedCBsDeleteButton	選択削除
⑯	CommandButton	GroupingSelectButton	グループを選択
⑰	ComboBox	GroupNumberComboBox
⑱	Label	Label4	選択CheckBoxの名前変更
⑲	TextBox	NewNameInputBox
⑳	CommandButton	NameChangeButton	変更

　
コードは、長いので、例によって今回も折りたたんでおく。

◆ソースコード：標準モジュール（クリックで展開）◆

Option Explicit

Function SetCheckBox(target_range As Range, _
            Optional cb_name As String = vbNullString, _
            Optional cb_caption As String = vbNullString) As CheckBox
    Dim CB As CheckBox
        ' チェックボックス配置。
        With target_range
            Set CB = ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
        End With
        
        ' 名前とキャプションの指定があれば、それに変更する。
        If cb_name <> vbNullString Then CB.Name = cb_name
        If cb_caption <> vbNullString Then
            CB.Caption = cb_caption
            
            ' サイズ獲得用にActiveXコントロール配置。
            Dim CBX As OLEObject
            ' サイズさえ取れれば良いので、配置位置は不問。
            Set CBX = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1")
            ' 途中で折り返したままサイズ調整されないよう、充分な長さに引き伸ばしておく。
                CBX.Width = 1000
            ' 指定キャプションをセットして、サイズを自動調整。
                CBX.Object.Caption = cb_caption
                CBX.Object.AutoSize = True
            
            ' フォームコントロールのチェックボックスにサイズ反映。
                CB.Width = CBX.Width
                CB.Height = CBX.Height
                
            ' 不要になったActiveXコントロールを削除。
                CBX.Delete
        End If
        
    Set SetCheckBox = CB
End Function

Public Property Get CBs() As CheckBoxes
    Set CBs = ActiveSheet.CheckBoxes
End Property

Public Property Get CheckBoxList() As Variant
    Dim arr() As Variant
        If CBs.Count = 0 Then
            CheckBoxList = Array()
            Exit Property
        Else
            ReDim arr(1 To CBs.Count, 1 To 3)
        End If
    Dim i
        On Error Resume Next
        For i = 1 To CBs.Count
            arr(i, 1) = CBs.Item(i).Name
            arr(i, 2) = CBs.Item(i).Caption
            arr(i, 3) = CLng(Split(CBs.Item(i).Name, "_")(1))
        Next
        CheckBoxList = arr
End Property

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

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

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

Public Function SortArray(ByVal arr As Variant, _
                       Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant
    Dim aryList As Object
    Dim s As Variant
    Set aryList = CreateObject("System.Collections.ArrayList")
    
    For Each s In arr
        Call aryList.Add(s)
    Next
    
    Select Case sort_order
        Case xlAscending
            ' 昇順でソート。
            Call aryList.Sort
        Case xlDescending
            ' 昇順でソートののち、降順へ反転。
            Call aryList.Sort
            Call aryList.Reverse
    End Select
    
    SortArray = aryList.ToArray
End Function

Private Sub UpdateGroupNumber()
    Dim TempDict As Object
    Set TempDict = CreateObject("Scripting.Dictionary")
    Dim CB As CheckBox
        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

◆ソースコード：ユーザーフォーム（クリックで展開）◆

Option Explicit

' チェックボックスの選択色。
Private Const SelectedColor As Long = vbRed
' チェックボックス選択色の透明度。
' ※１＝100％で完全な透明になる。
Private Const SelectedTransparency As Double = 0.7

Enum SelectType
    SelectAll = -10
    DeselectAll
    ListSelect
    [_eLast]
End Enum


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

Private Sub GroupNumberComboBox_Change()
    Dim SelectedGroupNumber As Long
        ' コンボボックスで選択したグループ番号（文字列）を、
        ' 変数に一旦格納する。
        ' ※この後、複数選択可否の切り替えで、コンボボックスの表示が
        ' 　初期化されてしまうため、現時点で退避させている。
        If GroupNumberComboBox.Value <> vbNullString Then
            SelectedGroupNumber = CLng(GroupNumberComboBox.Value)
        Else
            Exit Sub
        End If
    
        MultiSelectCheck.Value = True
        ' 選択したグループ番号と同じチェックボックスのみ選択。
        SelectSameGroup SelectedGroupNumber  ' <---------------ここ

        ' コンボボックスに、グループ番号を返して表示させる。
        ' 無限ループにならないよう、イベントは一時手停止。
        Application.EnableEvents = False
        GroupNumberComboBox.Value = SelectedGroupNumber
        Application.EnableEvents = True
End Sub

Private Sub GroupSelectButton_Click()
    Dim GroupNumber As Long
        On Error Resume Next
        GroupNumber = CBsListBox.List(CBsListBox.ListIndex, 2)
        
        ' グループに属していない場合、処理中断。
        If GroupNumber = 0 Then Exit Sub
        
        ' グループに属するボタンをすべて選択するために、
        ' リストボックスを複数選択可に切り替える。
        MultiSelectCheck.Value = True
        
        ' グループ番号が同じものを全て選択
        SelectSameGroup GroupNumber  ' <---------------ここ
End Sub

' 全選択と全解除を、ボタンを押すたびに切り替える。
Private Sub SelectAllButton_Click()
    Select Case SelectAllButton.Caption
        ' 全選択ボタンの場合。
        Case "全選択"
            MultiSelectCheck.Value = True
            SelectSameGroup SelectAll  ' <---------------ここ
            SelectAllButton.Caption = "全解除"
            
        ' 全解除ボタンの場合。
        Case "全解除"
            ResetCBsListBox
            SelectAllButton.Caption = "全選択"
    End Select
End Sub

Private Sub MultiSelectCheck_Change()
    ' リストボックスの着色解除。
    ResetCBsListBox

    ' リストボックスの複数選択可否を確認。
    Select Case MultiSelectCheck.Value
        ' 選択可の場合。
        Case True
            CBsListBox.MultiSelect = fmMultiSelectMulti
        ' 選択不可の場合。
        Case False
            CBsListBox.MultiSelect = fmMultiSelectSingle
            ' 一つしか選べないのだから、「全解除」は不適当。
            ' ボタンの状態が何であっても、全選択モードに切り替える。
            SelectAllButton.Caption = "全選択"
    End Select
    
    ' 選択可否に合わせて、キャプション変更ボタンの有効無効を切り替え。
    ' ※片方が有効の時、もう片方が無効の関係。
    CaptionChangeButton.Enabled = Not MultiSelectCheck.Value

    ' どれか一つの選択項目に対してグループを抽出するため、
    ' 複数選択の場合は無効とする。
    GroupSelectButton.Enabled = Not MultiSelectCheck.Value

End Sub

' リストボックスで選択されたチェックボックスを削除。
Private Sub SelectedCBsDeleteButton_Click()
    Dim i As Long
        For i = CBsListBox.ListCount - 1 To 0 Step -1
            If CBsListBox.Selected(i) = True Then
                CBs.Item(i + 1).Delete
            End If
        Next
        
        ' 削除後の状態を反映するために、リストボックスをリセットする。
        ResetCBsListBox
End Sub

Private Sub UserForm_Initialize()
    ' 初期値は、空白無視とする。
    ' ※使い勝手を考慮。
    IgnoreBlankCheck = True
    ' 既存のチェックボックス一覧をリストボックスに反映。
    ResetCBsListBox
End Sub

Private Sub UserForm_Terminate()
    ' チェックボックスへの一時的着色を、
    ' ユーザーフォームを閉じる際に解消。
    ResetCBsListBox
End Sub

Private Sub CloseButton_Click()
    Unload Me
End Sub

Private Sub CBsListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    ' リストボックスの選択状況に合わせて、チェックボックスを着色する。
    SelectSameGroup ListSelect
    
    ' リストが単一選択モードの場合、変更キャプション名入力補助として
    ' テキストボックスをフォーカス。
    If CBsListBox.MultiSelect = fmMultiSelectSingle Then
        NewCaptionInputBox.SetFocus
    End If
End Sub

Private Sub SetCheckBoxButton_Click()
    Dim r As Range
        For Each r In Selection
            ' 空白を無視しないか、または空白でない場合のみチェックボックス配置。
            If IgnoreBlankCheck = False Or r.Value <> vbNullString Then
                ' CheckBox配置。
                SetCheckBox r, , r.Value
                ' 置き換えのため、セルの文字を削除。
                r.ClearContents
            End If
        Next
        ' チェックボックスの増減があるため、リストボックスをリセット。
        ResetCBsListBox
End Sub

Private Sub CaptionChangeButton_Click()
    
    Dim SelectedIndex As Long
        SelectedIndex = CBsListBox.ListIndex
        
        ' チェックボックス選択確認。
        If SelectedIndex = -1 Then
            MsgBox "対象となるCheckBoxが未選択です。"
            Exit Sub
        End If
    
        ' チェックボックスのキャプション変更。
        CBs.Item(SelectedIndex + 1).Caption = NewCaptionInputBox.Value
        ' 次の入力に備え、テキストボックスを初期化。
        NewCaptionInputBox.Value = vbNullString
        ' キャプション変更を反映するために、リストボックスをリセット。
        ResetCBsListBox
        ' どのチェックボックスが選ばれていたかを明示するため、改めて
        ' 対象をリストから選択。
        CBsListBox.Selected(SelectedIndex) = True
End Sub

Private Sub NameChangeButton_Click()

    Dim SelectedIndex As Long
        SelectedIndex = CBsListBox.ListIndex

        ' チェックボックス選択確認。
        If SelectedIndex = -1 Then
            MsgBox "対象となるCheckBoxが未選択です。"
            Exit Sub
        End If
        
    Dim OldName As String
        OldName = CBs.Item(SelectedIndex + 1).Name
    
    ' 名前が既にグループ分けされているか否か確認するため、
    ' 「_」で分割して配列化する。
    Dim NameArray As Variant
        NameArray = Split(OldName, "_")
        
    Dim NewName As String
    ' 配列ならば、３つ目の値を置き換える。
    ' 配列でないならば、すべて置き換える。
        If UBound(NameArray) > 0 Then
            ReDim Preserve NameArray(0 To 2)
            NameArray(2) = NewNameInputBox.Value
            NewName = Join(NameArray, "_")
        Else
            NewName = NewNameInputBox.Value
        End If
    
        ' チェックボックスのキャプション変更。
        CBs.Item(SelectedIndex + 1).Name = NewName
        ' 次の入力に備え、テキストボックスを初期化。
        NewNameInputBox.Value = vbNullString
        ' キャプション変更を反映するために、リストボックスをリセット。
        ResetCBsListBox
        ' どのチェックボックスが選ばれていたかを明示するため、改めて
        ' 対象をリストから選択。
        CBsListBox.Selected(SelectedIndex) = True
End Sub

Private Sub ResetCBsListBox()
    CBsListBox.Clear
    CBsListBox.List = CheckBoxList
    GroupNumberComboBox.List = GroupList
    GroupNumberComboBox.Value = vbNullString
    SelectSameGroup DeselectAll  ' <---------------ここ
End Sub

Private Sub SelectSameGroup(group_number As SelectType)
    
    ' 基本的には、引数と同じグループ番号のチェックボックスを選択する。
    ' ただし、SelectTypeが指定された場合に限り、特別な処理を行う。
    Dim i As Long
        Select Case group_number
        
            ' チェックボックスを全て選択。
            Case SelectType.SelectAll
                For i = 0 To CBsListBox.ListCount - 1
                    CBsListBox.Selected(i) = True
                    CBs.Item(i + 1).Interior.Color = SelectedColor
                    CBs.Item(i + 1).ShapeRange.Fill.Transparency = SelectedTransparency
                Next
            
            ' チェックボックスを全て選択解除。
            Case SelectType.DeselectAll
                For i = 1 To CBs.Count
                    CBsListBox.Selected(i) = False
                    CBs.Item(i).Interior.Color = xlNone
                Next
                
            ' リストボックスで選択されたチェックボックスだけを選択。
            Case SelectType.ListSelect
                For i = 0 To CBsListBox.ListCount - 1
                    With CBs.Item(i + 1)
                        If CBsListBox.Selected(i) Then
                            .Interior.Color = SelectedColor
                            .ShapeRange.Fill.Transparency = SelectedTransparency
                        Else
                            .Interior.Color = xlNone
                        End If
                    End With
                Next
            
            ' 具体的なグループ番号が指定された場合。
            ' 指定グループ番号のチェックボックスを選択する。
            Case Else
                If group_number <> 0 Then
                    For i = 0 To CBsListBox.ListCount - 1
                        If CBsListBox.List(i, 2) = group_number Then
                            CBsListBox.Selected(i) = True
                            CBs.Item(i + 1).Interior.Color = SelectedColor
                            CBs.Item(i + 1).ShapeRange.Fill.Transparency = SelectedTransparency
                        Else
                            CBsListBox.Selected(i) = False
                            CBs.Item(i + 1).Interior.Color = xlNone
                        End If
                    Next
                End If
        End Select
End Sub

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 Property Get GroupList() As Variant
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim i As Long
        For i = 0 To CBsListBox.ListCount - 1
            If IsNumeric(CBsListBox.List(i, 2)) Then
                Dict(CBsListBox.List(i, 2)) = i
            End If
        Next
    Dim arr As Variant
        arr = Dict.keys
        
        GroupList = SortArray(arr)
End Property

　
　
今後は何かあれば、こちらを更新することとする。

本シリーズは、これでおしまい。

参考まで。