フィールド数が多いデータに取り組む④
進捗のみ CallByName関数がんばってみました。2キーでソート
CallByNameでプロパティもプロシージャもわたせるようでしたので,うまく動きました。
問題は,Key2の有無,昇順降順をサポートさせようとしたため,If文のお化けになりました(;´▽`A``
宣言モジュール
Option Explicit Public Const 列数 = 14 Public Enum C ID = 1 姓 名 姓_ふり 名_ふり カテゴリ 数値1 数値2 数値3 ラベル4 ラベル5 ラベル6 ラベル7 ラベル8 End Enum
メイン
Option Explicit Function GetDataAsCollection() As Collection Dim Arr: Arr = GetDataAsArray Dim Col As Collection: Set Col = New Collection Dim i, j, k For i = LBound(Arr, 1) + 1 To UBound(Arr, 1) With New person For j = 1 To 列数 .LetParameter j, Arr(i, j) Next Col.Add .Self End With Next Set GetDataAsCollection = Col End Function Function GetDataAsArray() As Variant GetDataAsArray = ThisWorkbook.Worksheets("データ").Range("a1").CurrentRegion.value End Function Sub CollectionSwap(Col As Collection, Index1 As Long, Index2 As Long) Dim Item1 As Variant, Item2 As Variant Set Item1 = Col.Item(Index1) Set Item2 = Col.Item(Index2) Col.Add Item1, after:=Index2 Col.Remove Index2 Col.Add Item2, after:=Index1 Col.Remove Index1 End Sub Sub メイン処理() Dim Col As Collection: Set Col = GetDataAsCollection 'ソート前出力 ThisWorkbook.Worksheets("出力").Range("a1").Resize(Col.Count, 列数) = Report(Col) CSort Col, C.カテゴリ, True, "ふりがな", True 'ソート結果出力 ThisWorkbook.Worksheets("出力").Range("a25").Resize(Col.Count, 列数) = Report(Col) End Sub Function Report(Col As Collection) As Variant Dim p As person, Rangearray() Dim i As Long, n As Long: n = 1 ReDim Rangearray(1 To Col.Count, 1 To 列数) For Each p In Col For i = 1 To 列数 Rangearray(n, i) = p.GetParameter(i) Next n = n + 1 Next Report = Rangearray End Function Sub CSort(Col As Collection, Key1 As String, Key1昇順 As Boolean, Optional Key2 As String, Optional Key2昇順 As Boolean) Dim p1 As person, p2 As person Dim p1k1 As Variant, p2k1 As Variant, p1k2 As Variant, p2k2 As Variant 'バブルソート Dim i As Long, j As Long For i = 1 To Col.Count For j = Col.Count To i Step -1 Set p1 = Col(i) Set p2 = Col(j) If IsNumeric(Key1) Then p1k1 = CallByName(p1, "GetParameter", VbMethod, Key1) p2k1 = CallByName(p2, "GetParameter", VbMethod, Key1) Else p1k1 = CallByName(p1, Key1, VbGet) p2k1 = CallByName(p2, Key1, VbGet) End If If Key2 <> "" Then If IsNumeric(Key2) Then p1k2 = CallByName(p1, "GetParameter", VbMethod, Key2) p2k2 = CallByName(p2, "GetParameter", VbMethod, Key2) Else p1k2 = CallByName(p1, Key2, VbGet) p2k2 = CallByName(p2, Key2, VbGet) End If End If If Key1昇順 = True Then If Key2 <> "" Then If p1k1 > p2k1 Then CollectionSwap Col, i, j ElseIf p1k1 = p2k1 Then If Key2昇順 = True Then If p1k2 > p2k2 Then CollectionSwap Col, i, j Else If p1k2 < p2k2 Then CollectionSwap Col, i, j End If End If Else If p1k1 > p2k1 Then CollectionSwap Col, i, j End If Else If Key2 <> "" Then If p1k1 < p2k1 Then CollectionSwap Col, i, j ElseIf p1k1 = p2k1 Then If Key2昇順 = True Then If p1k2 > p2k2 Then CollectionSwap Col, i, j Else If p1k2 < p2k2 Then CollectionSwap Col, i, j End If End If Else If p1k1 > p2k1 Then CollectionSwap Col, i, j End If End If Next j Next i End Sub
classモジュール
Option Explicit Private parameter(1 To 列数) Property Get ID() As Long ID = parameter(C.ID) End Property Property Get 氏名() As String 氏名 = parameter(C.姓) & " " & parameter(C.名) End Property Property Get ふりがな() As String ふりがな = parameter(C.姓_ふり) & " " & parameter(C.名_ふり) End Property Property Get カテゴリ() As String カテゴリ = parameter(C.カテゴリ) End Property Property Get 数値1() As Long 数値1 = parameter(C.数値1) End Property Property Get 数値2() As Long 数値2 = parameter(C.数値2) End Property Property Get 数値3() As Long 数値3 = parameter(C.数値3) End Property Sub LetParameter(paramno, value) parameter(paramno) = value End Sub Function GetParameter(paramno) As Variant GetParameter = parameter(paramno) End Function Property Get Self() As Object Set Self = Me End Property
実際動かしてみると,列挙をつかえるGetparameterは引数を間違えないんですが,プロパティのほうが文字列で与えなきゃいけなくて 間違いやすかった。
比較的簡単に,文字列をメンバで与えられるようにする方法ってあるのかなぁ(;´▽`A``