Excelデータを扱う コレクションラッパークラス④ 一段落

chemiphys.hateblo.jp
続きです。この流れのほぼ最終。

※UniqueList取得の際，ラベルの処理のつもりで最上行が１行ずつ消えてたのを確認したので，修正しました。
　下書きにいったん戻して公開したので，新しく書いたようになったのはすみません。_(._.)_

ひたすらいろいろ実装していくと，楽しいんですが大変なことになります。

自分にしかわからない(ﾟ▽ﾟ*)
いろいろできるようになったら，今度は機能実装の作法とか，そういうのを学ぶ時がくるんでしょう。

あれ，どこで紹介を読んだのかな，探しきれなかったけど

　　　まつもとゆきひろさん　の言語のしくみ

という本を買っています。これを読む時が来たんだろうなぁと思うきっかけとなりました。
コード書けるときは，ついそちらに集中して，本をなかなか読み進まない・・(;´▽｀A``

さて，どうなったのかということなんですが，標準モジュールにたくさん書いてみました。
列を減らしたり，出力にtransposeを対応させたり，と最初よりはいろいろ機能が増えてます。

実際のそれなりに多いデータで使ってみたい。
職場まで車で１時間かかるので，月曜まで我慢。

標準モジュールにほとんど依存しないつくりにしたので，他のクラスモジュールと共存できる，，と思っています(;´▽｀A``

標準モジュール

Option Explicit

Sub test()
    Dim Data As DataCollection: Set Data = New DataCollection
    Dim TargetSheet As Worksheet: Set TargetSheet = ThisWorkbook.Worksheets(1)
    TargetSheet.Range("a11:s30").ClearContents
    '元データを設定
    Data.GetData TargetSheet.Range("a1"), True
    
    '1キーソート　副キーから順に複数行えば複数キーによるソート
    Data.Sort 6, True

    Dim Data2 As DataCollection
    '検索条件に合うデータを抽出
    Set Data2 = Data.Extract(1, "<=", 5, 5, "=", "データA")

    '列を減らしたいときはReduce スペース区切りで　列番号を指定すると　その列のみにします。
    Dim data3 As DataCollection
    Set data3 = Data.Reduce("1 3 5")
    data3.Output TargetSheet.Range("b21"), True
    
    '検索条件に合うデータの要素数を数える。該当するコレクションを数えることで代用。直接のプロパティはヨウイシナカッタ
    Debug.Print Data.Extract(1, "<=", 5, 5, "=", "データA").SourceCollection.Count
    
    Dim a As Variant
    '重複無しリストをvariantで返す。添え字は１からにしています。第３引数を付けると，ワークシートに出力
    a = Data.UniqueList(5, False, TargetSheet.Range("l11"))
    Debug.Print Data.UniqueList(5, False)(1)      '要素を個別に出力
    Debug.Print UBound(Data.UniqueList(5, False)) '要素数を出力
    
    'Excelシートの起点セルからデータを出力，第二引数はラベル情報があるときTrueをつければラベルもつけて出力,
    '第三引数はoptionalで　trueにしたら縦横入れ替えます
    Data2.Output TargetSheet.Range("a11"), True

End Sub

ほんと，いろいろなことを実装してみました。カテゴライズされた重複無しのリストを出す，という機能だけ実装していません。
誰も使わないよな，と思ったのでコードが無駄に長くなるのを避けるために未実装のままです。

面白かったけど疲れた。。

DataCollection.cls
いろいろ実装したので，かなり長いです

Option Explicit
Private Col As Collection
Private LabelCol As DataUnit
Private ラベル有 As Boolean
Private pParameterCount As Long

Property Get SourceCollection() As Collection
    Set SourceCollection = Col
End Property

Property Let SourceCollection(pCol As Collection)
    Set Col = pCol
End Property

Property Get LabelData() As DataUnit
    Set LabelData = LabelCol
End Property
Property Let LabelData(ラベルデータ As DataUnit)
    Set LabelCol = ラベルデータ
    ラベル有 = True
End Property

Property Let ParameterCount(パラメーター数 As Long)
    pParameterCount = パラメーター数
End Property

Property Get PickupValue(行 As Long, 列 As Long) As Variant
    Dim d As DataUnit
    Set d = Col(行)
    PickupValue = d.GetParameter(列)
End Property

Sub GetData(BaseRange As Range, 先頭行ラベル As Boolean)
    Dim arr: arr = BaseRange.CurrentRegion.value
    Set Col = New Collection
    Set LabelCol = New DataUnit
    Dim i, j
    
    pParameterCount = UBound(arr, 2)
    For i = LBound(arr, 1) To UBound(arr, 1)
        With New DataUnit
            .SetParameterCount pParameterCount
            For j = 1 To pParameterCount
                .LetParameter j, arr(i, j)
            Next
            Col.Add .Self
        End With
    Next
    
    If 先頭行ラベル = True Then
        Set LabelCol = Col(1)
        Col.Remove 1
        ラベル有 = True
    Else
        ラベル有 = False
    End If
    
End Sub

Sub Output(BaseRange As Range, ラベル出力 As Boolean, Optional 縦横交換 As Boolean)
    Dim n As Long: n = 1
    Dim d As DataUnit
    Dim i As Long
    Dim tCol As Collection
    Set tCol = Col
    If ラベル出力 = True And ラベル有 = True Then
        tCol.Add LabelCol, , 1
    End If
    If tCol.Count = 0 Then
        BaseRange.value = "該当データなし"
        Exit Sub
    End If
    Dim RangeArray(): ReDim RangeArray(1 To tCol.Count, 1 To pParameterCount)
    
    For Each d In tCol
        For i = 1 To pParameterCount
            RangeArray(n, i) = d.GetParameter(i)
        Next
        n = n + 1
    Next

    If 縦横交換 = False Then
        BaseRange.Resize(tCol.Count, pParameterCount).value = RangeArray
    Else
        BaseRange.Resize(pParameterCount, tCol.Count).value = WorksheetFunction.Transpose(RangeArray)
    End If
    
End Sub

Sub Sort(Key As Long, 昇順 As Boolean)
    Dim d1 As Variant, d2 As Variant
    'バブルソート
    Dim i As Long, j As Long
    For i = 1 To Col.Count - 1
        For j = 1 To Col.Count - i
            
            d1 = CallByName(Col(j), "GetParameter", VbMethod, Key)
            d2 = CallByName(Col(j + 1), "GetParameter", VbMethod, Key)
            
            If IsGreater(昇順, d1, d2) Then CollectionSwap Col, j, j + 1
        Next j
    Next i

End Sub

Private Sub CollectionSwap(pCol As Collection, Index1 As Long, Index2 As Long)
    Dim Item1 As Variant, Item2 As Variant
    Set Item1 = pCol.Item(Index1)
    Set Item2 = pCol.Item(Index2)
    
    pCol.Add Item1, after:=Index2
    pCol.Remove Index2
    pCol.Add Item2, after:=Index1
    pCol.Remove Index1
End Sub

Private Function IsGreater(which, a, B) As Boolean
    Select Case which
        Case True: IsGreater = a > B
        Case False: IsGreater = a < B
    End Select
End Function

Function Extract(Optional キー1列 As Variant, Optional 演算子1 As String, Optional 値1 As Variant, _
                 Optional キー2列 As Variant, Optional 演算子2 As String, Optional 値2 As Variant, _
                 Optional キー3列 As Variant, Optional 演算子3 As String, Optional 値3 As Variant, _
                 Optional キー4列 As Variant, Optional 演算子4 As String, Optional 値4 As Variant, _
                 Optional キー5列 As Variant, Optional 演算子5 As String, Optional 値5 As Variant) As DataCollection
    Dim tCol As Collection: Set tCol = New Collection
    Dim d As DataUnit
    Dim flg追加 As Boolean
    
    For Each d In Col
        flg追加 = True
        If IsMissing(キー1列) Then GoTo Flag
        If 抽出演算(d.GetParameter(キー1列), 演算子1, 値1) = False Then flg追加 = False
        If IsMissing(キー2列) Then GoTo Flag
        If 抽出演算(d.GetParameter(キー2列), 演算子2, 値2) = False Then flg追加 = False
        If IsMissing(キー3列) Then GoTo Flag
        If 抽出演算(d.GetParameter(キー3列), 演算子3, 値3) = False Then flg追加 = False
        If IsMissing(キー4列) Then GoTo Flag
        If 抽出演算(d.GetParameter(キー4列), 演算子4, 値4) = False Then flg追加 = False
        If IsMissing(キー5列) Then GoTo Flag
        If 抽出演算(d.GetParameter(キー5列), 演算子5, 値5) = False Then flg追加 = False
Flag:
        If flg追加 = True Then tCol.Add d
    Next
    
    Dim NewData As DataCollection: Set NewData = New DataCollection
    NewData.SourceCollection = tCol
    If ラベル有 = True Then NewData.LabelData = Me.LabelData
    NewData.ParameterCount = pParameterCount
    
    Set Extract = NewData
End Function

Private Function 抽出演算(値 As Variant, 演算子 As String, 該当値 As Variant) As Boolean
    抽出演算 = False
    Select Case 演算子
        Case "="
            If 値 = 該当値 Then 抽出演算 = True
        Case ">"
            If 値 > 該当値 Then 抽出演算 = True
        Case "<"
            If 値 < 該当値 Then 抽出演算 = True
        Case ">="
            If 値 >= 該当値 Then 抽出演算 = True
        Case "<="
            If 値 <= 該当値 Then 抽出演算 = True
    End Select
End Function

Function UniqueList(列番号 As Long, 昇順 As Boolean, Optional BaseRange As Variant) As Variant
    Dim db As Object: Set db = CreateObject("Scripting.Dictionary")
    Dim i As Long
    Dim NewDataCollection As DataCollection: Set NewDataCollection = New DataCollection
    
    NewDataCollection.SourceCollection = Me.SourceCollection
    NewDataCollection.Sort 列番号, 昇順
    
    For i = 1 To NewDataCollection.SourceCollection.Count
        db(NewDataCollection.PickupValue(i, 列番号)) = 1
    Next
    
    Dim arr As Variant
    arr = db.keys
    

    ReDim Preserve arr(1 To UBound(arr) + 1)
    
    UniqueList = arr
    
    If IsObject(BaseRange) = False Then Exit Function
        
    BaseRange.Resize(UBound(arr), 1).value = WorksheetFunction.Transpose(arr)
    
End Function

Function Reduce(列リスト As String) As DataCollection
    Dim tCol As Collection: Set tCol = New Collection
    Dim d As DataUnit
    Dim ListCount As Long: ListCount = UBound(Split(列リスト, " ")) + 1
    If ListCount = 0 Then Exit Function
    Dim arr(): ReDim arr(1 To ListCount)
    Dim i As Long
    For i = 1 To ListCount
        arr(i) = Split(列リスト, " ")(i - 1)
    Next
    
    Set tCol = Col
    If ラベル有 = True Then
        tCol.Add LabelCol, , 1
    End If
    
    Dim NewCol As Collection: Set NewCol = New Collection
    For Each d In tCol
        With New DataUnit
            .SetParameterCount ListCount
            For i = 1 To ListCount
                .LetParameter i, d.GetParameter(arr(i))
            Next
            NewCol.Add .Self
        End With
    Next
                
    Set Reduce = New DataCollection
    If ラベル有 = True Then
        Set d = NewCol(1)
        Reduce.LabelData = d
        NewCol.Remove 1
    End If
    Reduce.ParameterCount = ListCount
    Reduce.SourceCollection = NewCol
End Function

DataUnit.cls
これはほぼ変わってない

Option Explicit
Private Parameter()
Private pパラメーター数 As Long

Property Get Self() As Object
    Set Self = Me
End Property

Sub SetParameterCount(パラメーター数 As Long)
    ReDim Parameter(1 To パラメーター数)
    pパラメーター数 = パラメーター数
End Sub

Sub LetParameter(paramNo, value)
    Parameter(paramNo) = value
End Sub

Function GetParameter(paramNo) As Variant
    GetParameter = Parameter(paramNo)
End Function