配列の重複削除 ③ 範囲やテーブルの任意の一列からも、重複の無い一次元配列を作成してみる
昨日は、二次元配列の任意の一列から、重複の無い一次元配列を作成してみた。
infoment.hatenablog.com
しかし、このままでは未だ足りない。もう少し機能拡張してみよう。
ということで、昨日のものを少し弄ってみた。
- 配列だけでなく、範囲(Range)またはテーブル(ListObject)も受け取る。
- 範囲の場合は、「L列」のようにアルファベットでも指定できるようにする。
ただし、範囲がA列から始まっていない場合は要注意。 - テーブルの場合は、ラベル名でも指定できるようにする。
コードが、だんだん長くなってきた。
いずれ分割も検討するとして、現状はこんな感じ。
Function RemovalDuplicateArray(ByVal source As Variant, _ Optional ByVal target_column_index As Variant = 1) As Variant ' 配列確認。 Dim source_array As Variant ' 配列に格納できないものがセットされる場合を想定し、一時的にエラーを無視。 On Error Resume Next ' sourceを範囲で指定された場合。 If TypeName(source) = "Range" Then ' 列番号がアルファベットで指定された場合、数値に変換する。 If IsNumeric(target_column_index) = False Then target_column_index = StrConv(target_column_index, vbNarrow + vbUpperCase) If target_column_index Like "*[A-Z]*" Then target_column_index = Cells(1, target_column_index).Column End If source_array = source.Value End If ' sourceがテーブルの場合。 ElseIf TypeName(source) = "ListObject" Then source_array = source.DataBodyRange.Value ' 列がラベル名で指定されている場合、列番号に置き換える。 If IsNumeric(target_column_index) = False Then target_column_index = source.ListColumns(target_column_index).Index End If ' sourceが上記以外であって、且つ、配列ではない場合(例えば文字列などの場合)。 ElseIf IsArray(source) = False Then source_array = Array(source) End If ' 上記でエラーが発生していた場合の処理。 If Err.Number <> 0 Then GoTo er: ' 配列の次元数を確認。 Dim i As Long For i = 1 To 3 Debug.Print UBound(source_array, i) If Err.Number <> 0 Then Exit For Next On Error GoTo 0 Dim DimensionNumber As Long DimensionNumber = i - 1 ' 作業用配列。 Dim TempArray As Variant Select Case DimensionNumber ' 一次元配列の場合。 Case 1 TempArray = source_array ' 二次元配列の場合、目的列を抜き出し。 Case 2 TempArray = WorksheetFunction.Index(source_array, 0, target_column_index) ' 三次元以上は対応しない。 Case Else GoTo er: End Select ' 重複除去用の辞書(連想配列) Dim Dict As Object Set Dict = CreateObject("Scripting.Dictionary") Dim a As Variant For Each a In TempArray ' 配列内の各値を、辞書に格納する。 ' 重複除去が目的のため、itemは不問。今回は「1」とした。 Dict(a) = 1 Next ' 辞書のkeyが、重複除去後の配列として取り出せる。 RemovalDuplicateArray = Dict.keys Exit Function er: RemovalDuplicateArray = Array() On Error GoTo 0 End Function
それではこちら、なんちゃって個人情報を元に作成したテーブルで試してみよう。
都道府県の列から、重複の無い一次元配列を作成する。
Sub ArrayTest() Dim arr As Variant arr = RemovalDuplicateArray(ActiveSheet.ListObjects(1), "都道府県") MsgBox Join(arr, vbNewLine) End Sub
結果がこちら。
一区切りつくまで、あと少し。次回に続きます。
参考まで。