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

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

Excelデータを扱う　コレクションラッパークラス③

Excel VBA

chemiphys.hateblo.jp
つつきです。

データ抽出部分を実装してみました。
ここらへんになると，だいぶコードが長くなってくるので良し悪し。

汎用性は失われつつある気はしますが，自分の欲求に特化していく感じです。(;´▽｀A``ワタシニハ，ヤクニタツ

標準モジュール

Sub Test()
    Dim Data As DataCollection: Set Data = New DataCollection
    Dim Data2 As DataCollection: Set Data2 = New DataCollection
    Dim TargetSheet As Worksheet: Set TargetSheet = ThisWorkbook.Worksheets(1)
    Data.GetData TargetSheet.Range("a1"), True
    
    Data.Sort 6, False
    
    Data2.SourceCollection = Data.ExtractCollection(1, ">", 1) ', 5 , "=", "データA")
    Data2.LabelData = Data.LabelData
    
    TargetSheet.Range("a11:j18").ClearContents
    Data2.Output ThisWorkbook.Worksheets(1).Range("a11"), True

End Sub

DataCollection.cls
データ抽出用に DataCollectionを別のにコピーできるように内部のCollectionやLabelDataを取得，設定できるように変わりました。
ExtractCollectionという，５キーまで抽出できるFunctionを実装してみています。もうちょい改善が必要。ループで短くもできるのかな。宣言加えればあんまり変わらないかもだけど。
If文のお化けにならなくなったのは，少し成長しました(ﾟ▽ﾟ*)

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

Sub GetData(BaseRange As Range, 先頭行ラベル As Boolean)
    Dim arr: arr = BaseRange.CurrentRegion.value
    Set Col = New Collection
    Set LabelCol = New DataUnit
    Dim i, j
    
    ParameterCount = UBound(arr, 2)
    For i = LBound(arr, 1) To UBound(arr, 1)
        With New DataUnit
            .SetParameterCount ParameterCount
            For j = 1 To ParameterCount
                .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)
    Dim n As Long: n = 1
    Dim d As DataUnit
    Dim i As Long
    If ラベル出力 = True And ラベル有 = True Then
        Col.Add LabelCol, , 1
    End If
    If Col.Count = 0 Then
        BaseRange.value = "該当データなし"
        Exit Sub
    End If
    'GetDataを通っていない場合，コレクションから取得させる
    If ParameterCount = 0 Then ParameterCount = Col(1).パラメーター数
    Dim RangeArray(): ReDim RangeArray(1 To Col.Count, 1 To ParameterCount)
    
    For Each d In Col
        For i = 1 To ParameterCount
            RangeArray(n, i) = d.GetParameter(i)
        Next
        n = n + 1
    Next

    BaseRange.Resize(Col.Count, ParameterCount).value = RangeArray
    
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

Property Get ExtractCollection(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 Collection
    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
    
    Set ExtractCollection = tCol
End Property
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)
    If ラベルデータ.パラメーター数 = 0 Then Exit Property
    Set LabelCol = ラベルデータ
    ラベル有 = True
End Property

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

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

DataUnit.xls
ちょっと余計なパラメーターが増えましたが，最終的には消せるように・・したい。

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

Property Get パラメーター数() As Long
    パラメーター数 = pパラメーター数
End Property

５キーまで検索を許容するのは，かなりコードが長くなるかなーと思いましたが，以前教えていただいた経験が役に立ったと思っています。
テストは２キーまでしかしていませんけど。。たぶん，いける・・はず。

あとは，目的の列のみ部分抽出，重複除去抽出，該当データ数の出力。

めんどくさそうなとこを先にやりましたし，抽出ができたので，これを利用すれば未実装の部分もいける気がする。