昨日は、作成したチェックボックスのグループ番号更新に挑戦した。
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 ' チェックボックス選択色の透明度。 ' ※1=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 ' 配列ならば、3つ目の値を置き換える。 ' 配列でないならば、すべて置き換える。 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
今後は何かあれば、こちらを更新することとする。
本シリーズは、これでおしまい。
参考まで。