コンボボックスのリストを、選択頻度の高い順に並び替えてみる
このような課題を見かけたので、自分なりに考えてみた。
UserFormのコンボボックスに出てくるリストについて、選択回数が多いものを上に表示させたい。
リストの並び順を、動的に変更したいとのこと。しかも、前回選んだものが今回トップに来るのではなく、選択回数でコントロールする必要がある。
そこでまず、テスト用にユーザーフォームを準備する。コンボボックスが一つ配置されただけの、とてもシンプルな作りだ。
今回の作戦は、こうだ。
１．リスト用に二次元配列を準備する。
２．コンボボックスの値が変わるたび、選択されたものをカウントアップする。
３．カウントアップ後、同回数で降順にソートして、リストを更新する。
確認用に、combobox1のColumnCountを２にしておく。
ユーザーフォームのモジュールレベル変数
' 二次元配列のソート用クラスモジュール。 Dim SQC As SeaquenceClass ' コンボボックスのリスト用配列。 Dim arr(2, 1) As Variant
ユーザーフォームの初期化
Private Sub UserForm_Initialize() Set SQC = New SeaquenceClass arr(0, 0) = "りんご": arr(0, 1) = 1 arr(1, 0) = "みかん": arr(1, 1) = 1 arr(2, 0) = "ばなな": arr(2, 1) = 1 ComboBox1.List = arr End Sub
※数字の１は、便宜上「選択ポイント」と呼ぶことにする。
※選択頻度が大きいほど、ポイント数は大きくなる。
ここまでで実行すると、このようになる。
各果物の選択頻度は、現時点で同率の１ポイント。
次いで、ComboBoxのチェンジイベントを設定する。例えば「みかん」を選ぶと、選択ポイントに３（＝選択肢の数）が加算される。そして加算した結果を含め一旦リストを配列化し、選択ポイントでソートしてコンボボックスに返している。
Private Sub ComboBox1_Change() ' 選択ポイント加算。 ComboBox1.List(ComboBox1.ListIndex, 1) = ComboBox1.List(ComboBox1.ListIndex, 1) + UBound(arr) + 1 ' リストを一旦配列化。 Dim i As Long Dim j As Long For i = 0 To 2 For j = 0 To 1 arr(i, j) = ComboBox1.List(i, j) Next Next ' リスト用配列を選択ポイントで降順ソート。 Dim tempArr As Variant tempArr = SQC.SortArray2D(arr, 1, xlDescending) ' リスト用配列をコンボボックスに返す。 ComboBox1.List = tempArr End Sub
ユーザーフォーム側としては、ここまで。後は二次元配列のソート用に、クラスモジュールを準備する。
クラスモジュール（SeaquenceClass）
※ ↓ を丸ごとコピペで可。
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 Public Function SortArray2D(ByVal arr As Variant, _ Optional sort_column As Long = 1, _ Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant ' 各行要素を一次元配列として抽出し、ソートしたい列の値を付して「,」で結合｡ ' これらで構成された一次元を作成する。 ' ※列のデータを、一番左のセルにギュッと寄せて、ソートしたい列の値を先頭に付すイメージ｡ Dim TempArray() As Variant ReDim TempArray(LBound(arr) To UBound(arr)) Dim RowArray As Variant Dim SortKey As String Dim i As Long ' ソート列を抜き出して新たな配列を作成し、配列内の最大値を求める。 Dim cMax As Long cMax = WorksheetFunction.Max(ExtractArray2(arr, sort_column)) ' 最大値の桁数ｄを求め、１０のｄ乗の数を求める。 ' これをソートする列に加えることで、文字列であっても数字と ' 同じソート結果を得られる。 Dim d As Long d = DigitNumber(cMax) Dim AdjustNumber As Long AdjustNumber = 10 ^ d Dim AdditionalCharacter As Variant For i = LBound(arr) To UBound(arr) RowArray = ExtractArray2(arr, i, i) AdditionalCharacter = arr(i, sort_column) If IsNumeric(AdditionalCharacter) Then AdditionalCharacter = AdjustNumber + AdditionalCharacter End If TempArray(i) = AdditionalCharacter & "," & Join(RowArray, ",") Next ' 一次元配列としてソート。 TempArray = SortArray(TempArray, sort_order) ' ソートした結果を再び分割し、新たな配列に振りなおす。 Dim DestinationArray() As Variant ReDim DestinationArray(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2)) Dim j As Long For i = LBound(TempArray) To UBound(TempArray) RowArray = Split(TempArray(i), ",") ' ０番目の要素はソート用であるため不要 ⇒ １番目からループ。 For j = 1 To UBound(RowArray) DestinationArray(LBound(arr) + i, LBound(arr) + j - 1) = RowArray(j) Next Next SortArray2D = DestinationArray End Function ' sorce_array 抽出元の配列 ' r_min 一次元要素の下限 ' r_max 一次元要素の上限 ' c_min 二次元要素の下限 ' c_max 二次元要素の上限 ' to_1d_flag 一次元または二次元の上限と下限が一致する場合、 ' 抽出後の配列を一次元配列に変換するか否かのフラグ。 Function ExtractArray2(ByVal sorce_array As Variant, _ Optional r_min As Long = -1, _ Optional r_max As Long = -1, _ Optional c_min As Long = -1, _ Optional c_max As Long = -1, _ Optional to_1d_flag As Boolean = True) As Variant ' 二次元配列であることの確認 If GetArrayDimension(sorce_array) <> 2 Then ExtractArray2 = Array(): Exit Function End If ' 下限確認。 ' 指定下限が無指定の場合、抽出元配列の下限を指定下限とする。 ' ※指定下限が指定上限を上回る場合については、指定上限側で対処する。 ' 指定下限が負の値の場合、指定下限を０とする。 ' 指定下限が抽出元配列の下限を下回る場合、これを認める。 If r_min = -1 Then r_min = LBound(sorce_array, 1) ElseIf r_min < 0 Then r_min = 0 End If If c_min = -1 Then c_min = LBound(sorce_array, 2) ElseIf c_min < 0 Then c_min = 0 End If ' 上限確認。 ' 指定上限が無指定の場合、抽出元配列の上限を指定上限とする。 ' 指定上限が指定下限を下回る場合、指定下限を指定上限とする。 ' 指定上限が抽出元配列の上限を上回る場合、これを認める。 If r_max = -1 Then r_max = UBound(sorce_array, 1) ElseIf r_max < r_min Then r_max = r_min End If If c_max = -1 Then c_max = UBound(sorce_array, 2) ElseIf c_max < c_min Then c_max = c_min End If ' 抽出用配列。 Dim TempArray() As Variant ReDim TempArray(1 To r_max - r_min + 1, 1 To c_max - c_min + 1) Dim r As Long Dim C As Long ' 値抽出。 For r = r_min To r_max For C = c_min To c_max On Error Resume Next TempArray(r - r_min + 1, C - c_min + 1) = sorce_array(r, C) Next Next ' １行または１列の配列の場合、二次元配列を一次元配列に変換。 ' ※to_1d_flag = True の場合のみ If to_1d_flag Then If UBound(TempArray, 2) = 1 Then TempArray = WorksheetFunction.Transpose(TempArray) ElseIf UBound(TempArray, 1) = 1 Then TempArray = WorksheetFunction.Transpose(TempArray) TempArray = WorksheetFunction.Transpose(TempArray) End If End If ExtractArray2 = TempArray End Function Private Function GetArrayDimension(arr As Variant) As Long If IsArray(arr) = False Then GetArrayDimension = -1 Exit Function End If ' 配列の次元数を取得。 Dim i As Long Dim TempNumber As Long On Error Resume Next Do While Err.Number = 0 i = i + 1 TempNumber = UBound(arr, i) Loop GetArrayDimension = i - 1 End Function Function DigitNumber(num As Variant) As Long Dim i As Long: i = 10 Dim j As Long: j = 1 Do If num / i < 1 Then DigitNumber = j Exit Function Else i = i * 10 j = j + 1 End If Loop End Function
結果、このようになった。
なお、選択ポイントの表示が不要の場合は、ComboBox の ColumnCount を１にしておけばＯＫです。
参考まで。
