Excel VBA 重複のない入力規制のリストを設定する
バブルソートと重複削除を行い、入力規制のリストを実用的なプルダウンメニューとして利用できるようにするマクロです。
入力規制の設定において、[入力値の種類]で[リスト]を選択すると、任意のセル範囲を設定することができ、入力時にプルダウンメニューから任意の値を選択することができるようになります。
確かに便利な機能ですが、選択範囲のデータが重複していたり、並び順がおかしい場合でもそのまま反映されてしまうため、プルダウンメニューとしては実用性に欠けます。
そこで、選択範囲のデータを配列に入れ、バブルソートで昇順に並べ替え、重複データを削除したリストを作成し、入力規制に設定するまでのマクロを作成しました。
処理の流れ
右クリックメニューからユーザーフォームを表示させ、リストにする対象範囲をRange Refコントロールから選択させて実行するのが王道かと思います。細かいインターフェースの説明は割愛します。
1. メインルーチンの setValidateList に「入力規制を設定するセル範囲」と「入力規制のリストとして利用するセル範囲」を渡す。
2. 「入力規制のリストとして利用するセル範囲」を配列に入れ、バブルソートで昇順に並び替える。
3. 重複したデータを取り除いて配列に入れる。
4. 配列の内容をカンマ区切りのテキストにする。
5. 「入力規制を設定するセル範囲」の入力規制リストにカンマ区切りのテキストを設定する。
ソースコード
標準モジュールに下記のコードを貼り付けてください。
'-------------------------------------------- '入力規制リストを設定する（メイン） '-------------------------------------------- Sub setValidateList(targetRange As Range, sourceRange As Range) Dim sourceArray As Variant Dim counter As Long '選択範囲を配列に入れる ReDim sourceArray(sourceRange.Count) For counter = 0 To UBound(sourceArray) - 1 sourceArray(counter) = sourceRange.Item(counter + 1) Next
'バブルソート＞＞重複削除 Dim gArray As Variant: gArray = getGroupArray(getBubbleSort(sourceArray)) Dim listString As String '配列をカンマ区切りのテキストにする For counter = 0 To UBound(gArray) listString = listString & "," & gArray(counter) Next listString = Mid(listString, 3, Len(listString)) '入力規制を設定する With targetRange.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=listString .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With End Sub '-------------------------------------------- '重複を取り除いた配列を返す '-------------------------------------------- Function getGroupArray(inArray As Variant) Dim inCounter As Long Dim outArray() As Variant Dim outCounter As Long For inCounter = 0 To UBound(inArray) If inCounter = 0 Then ReDim outArray(outCounter) outArray(outCounter) = inArray(inCounter) Else If outArray(outCounter) <> inArray(inCounter) Then outCounter = outCounter + 1 ReDim Preserve outArray(outCounter) outArray(outCounter) = inArray(inCounter) End If End If Next getGroupArray = outArray End Function '-------------------------------------------- 'バブルソート '-------------------------------------------- Function getBubbleSort(myArray As Variant) Dim counter1 As Long, counter2 As Long Dim ubound1 As Long, ubound2 As Long Dim tmp As Variant ubound1 = UBound(myArray) ubound2 = ubound1 counter1 = 0 Do While (counter1 < ubound1) counter2 = 0 Do While (counter2 < ubound2) If (myArray(counter2) > myArray(counter2 + 1)) Then tmp = myArray(counter2) myArray(counter2) = myArray(counter2 + 1) myArray(counter2 + 1) = tmp End If counter2 = counter2 + 1 Loop ubound2 = ubound2 - 1 counter1 = counter1 + 1 Loop getBubbleSort = myArray End Function
