インストールレスプログラミング( ´ー`)

VBA , JavaScript , HTAなど 365アプリはインストール必要ですが、仕事に無いケースはほぼないから(・_・;)

フィールド数が多いデータに取り組む④

進捗のみ CallByName関数がんばってみました。2キーでソート
CallByNameでプロパティもプロシージャもわたせるようでしたので,うまく動きました。

問題は,Key2の有無,昇順降順をサポートさせようとしたため,If文のお化けになりました(;´▽`A``
f:id:chemiphys:20170110122720p:plain

宣言モジュール

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``