ListBoxで選択したCheckBoxの色を一時的に変更する - Infomentのブログ～Excel VBA奮闘記～

先日は、選択範囲の文字列をチェックボックス（フォームコントロール）に置き換えることに挑戦した。
infoment.hatenablog.com

今日は、シート上にあるチェックボックスをユーザーフォームのリストボックスに表示し、さらに、選択したチェックボックスの色を一時的に変更して見える化することに挑戦する。
f:id:Infoment:20191109180916p:plain

今更だが、先に断っておく。今回一連の取り組みは、一貫して不毛である。なぜなら、CheckBoxをOptionButtonに置き換えるだけで、全ての問題が解決するからだ。

まず先日のユーザーフォームに、チェックボックスをリスト表示するためのリストボックスを追加した。また、これに伴い、レイアウトも少し変更した。

【変更前】
f:id:Infoment:20191107224001p:plain
【変更後】
f:id:Infoment:20191109181342p:plain

常に最新のリストを取得するために、チェックボックスの一覧取得はPropertyで取得することにした。

標準モジュール

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 2)
        End If
    Dim i
        For i = 1 To CBs.Count
            arr(i, 1) = CBs.Item(i).Name
            arr(i, 2) = CBs.Item(i).Caption
        Next
        CheckBoxList = arr
End Property

ユーザーフォーム

Private Sub CBsListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim i As Long
        ' リストボックスの選択状況に合わせて、
        ' チェックボックスを着色する。
        For i = 0 To CBsListBox.ListCount - 1
            With CBs.Item(i + 1)
                If CBsListBox.Selected(i) Then
                    .Interior.Color = vbRed
                    ' 透明度70％
                    .ShapeRange.Fill.Transparency = 0.7
                Else
                    .Interior.Color = xlNone
                End If
            End With
        Next
End Sub

Private Sub CloseButton_Click()
    Unload Me
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
        ' チェックボックスの増減があるため、一旦リストボックスをクリア。
        CBsListBox.Clear
        ' リストの再セット。
        CBsListBox.List = CheckBoxList
End Sub

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

Private Sub UserForm_Terminate()
    ' チェックボックスへの一時的着色を、
    ' ユーザーフォームを閉じる際に解消。
    Dim i As Long
        For i = 0 To CBsListBox.ListCount - 1
            CBs.Item(i + 1).Interior.Color = xlNone
        Next
End Sub