Excel VBA フィルターをかけた際に表示されている値だけを配列に格納する実装

Question

前提・実現したいこと

ExcelVBAのフィルターと配列についてご質問をさせてください。
下記はサンプルデータになります。

列が2列あり、複数の値がそれぞれ記載されています。
１．1列目のデータを重複無しで配列に格納
２．配列1つ目の値でフィルターを設定
３．フィルター後、2列目に現在表示されている値だけを別の配列に格納
という処理を行いたいです。
例えば上記画像ですと、A列の値1でフィルターをかけ、B列の表示されている値（A,A,B)のみを配列に入れたいです。
３．のフィルター後に表示されている値「だけ」を配列に格納するという手段がわからず、お教え頂きたいです。
また、データ行が30000行程あり、なるべく高速な処理を行いたいです。

発生している問題・エラーメッセージ

該当のソースコード

言語：VBA

※現状は下記ソースで重複無しのデータを配列に取得しているのですが、
こちらだとフィルター後に取得してもすべての値を取得してしまうため、ご質問させて頂きました。

Sub Duplicate_Delete(ByVal ORIGIN_SHEET_NAME As String, ByRef hairetsu() As String, ByVal rngTaishoColumn As Integer)

Dim myDic As Object, myKey As Variant
Dim c As Variant, vardata As Variant
Dim lp As Integer
Dim Maxrow As Long

Set myDic = CreateObject("Scripting.Dictionary")
With Worksheets(ORIGIN_SHEET_NAME)
Maxrow = .Cells(Rows.Count, rngTaishoColumn).End(xlUp).Row
    vardata = .Range(.Cells(2, rngTaishoColumn), .Cells(Maxrow, rngTaishoColumn)).Value
End With
For Each c In vardata
    If Not c = Empty Then
        If Not myDic.Exists(c) Then
            myDic.Add c, Null
        End If
    End If
Next

lp = 0
myKey = myDic.Keys
ReDim hairetsu(lp)

For i = 0 To myDic.Count - 1
    If myKey(i) <> "*" Then
        hairetsu(lp) = myKey(i)
        lp = lp + 1
        If i <> myDic.Count - 1 Then
            ReDim Preserve hairetsu(lp)
        End If
    End If
Next i

Set myDic = Nothing

End Sub

試したこと

補足情報（FW/ツールのバージョンなど）

MS Excel Office365 32Bit

Comments

[sinzou]

http://officetanaka.net/excel/vba/tips/tips155d.htm
絞り込んだ結果の行を操作する

参考になりませんか？

[mattuwan]

>３．フィルター後、2列目に現在表示されている値だけを別の配列に格納
この後はどうしたいのですか？

[kuta]

＞sinzou様
ご回答ありがとうございます。
確認しましたところ、少し応用は必要ですが実装できそうかなと思っています。
もう少し調べてみます。

＞mattuwan様
ご回答ありがとうございます。
申し訳ありません。質問ではわかりやすいように2列で説明したのですが、
本番ではフィルタをかける列が4列あり、
また最終的に欲しい数値が記載された列が1列あります。
フィルタをかけたあと、その列の合計値をまとめシートに記載していく、という流れになります。

>３．フィルター後、2列目に現在表示されている値だけを別の配列に格納
→このあとは、2列目の配列の1番目の値でフィルタをかける
　→フィルター後、3列目に現在表示されている値だけを別の配列に格納
　　→3列目の配列の1番目の値でフィルタをかける
　　　→フィルター後、4列目に現在表示されている値だけを別の配列に格納
　 →4列目の配列の1番目の値でフィルタをかける
　 　→別の列に記載されている値を合計してまとめ表に記載する
　 →4列目の配列の2番目の値でフィルタをかける・・・

という風に進める予定です。

[meg_]

コードは「コードの挿入」で記入してください。

[kuta]

meg_様
失礼しました。次回よりそのように記入致します。

Answer 1

まず、VBE (VBAのエディタ) の上部メニューの ツール → 参照設定 を選択し、
「Microsoft Scripting Runtime」にチェックを入れてください。

その上で、質問者様が実施されたいことを実装しました。
質問から、A列～D列の文字列ごとにE列などに記載された数値の合計を算出したいのだと理解したので、
質問者様のプログラムとは大きく変更しましたが、
以下はそれなりにきれいな実装なのではないでしょうか。

Option Explicit

' 処理実行メインモジュールです
Sub Main()
    
    ' 変数宣言
    Dim datas As Variant
    Dim sheet As Worksheet
    Dim filterdData() As Variant
    Dim columnItemsA As Collection
    Dim columnItemA As Variant
    Dim columnItemsB As Collection
    Dim columnItemB As Variant
    Dim columnItemsC As Collection
    Dim columnItemC As Variant
    Dim columnItemsD As Collection
    Dim columnItemD As Variant
    
    ' 処理を実行するシートを取得します
    Set sheet = ThisWorkbook.Worksheets("処理対象シート")
    
    ' 全セルの値を取得します (但し1行目は空行のため2行目から取得します)
    datas = readData(sheet, "A2")
    
    ' 重複を排除したA列～D列の値を取得
    Set columnItemsA = removeDuplication(getColumnData(datas, 1))
    Set columnItemsB = removeDuplication(getColumnData(datas, 2))
    Set columnItemsC = removeDuplication(getColumnData(datas, 3))
    Set columnItemsD = removeDuplication(getColumnData(datas, 4))
    
    ' 全ての値のパターンごとに行を抽出して合計値 (便宜的に5行目に数字が記載されていると仮定) を計算します
    For Each columnItemA In columnItemsA
        For Each columnItemB In columnItemsB
            For Each columnItemC In columnItemsC
                For Each columnItemD In columnItemsD
                    filterdData = filterData(datas, columnItemA, columnItemB, columnItemC, columnItemD)
                    Debug.Print (columnItemA & ", " & columnItemB & ", " & columnItemC & ", " & columnItemD & " = " & sumData(filterdData, 5))
                Next
            Next
        Next
    Next
    
End Sub

' 指定列の数字を全て足した結果を返却します
' 数字以外が混じっていた場合はVBAのエラーが発生します
Private Function sumData(filterdData() As Variant, columnNumber As Long) As Long
    
    ' 変数宣言
    Dim i As Long
    Dim sum As Long
    
    ' 全ての数字を足します
    sum = 0
    If IsEmptyArray(filterdData) Then
        sumData = sum
        Exit Function
    End If
    For i = LBound(filterdData) To UBound(filterdData)
        sum = sum + CLng(filterdData(i, columnNumber))
    Next
    sumData = sum
    
End Function

' ワークシートのデータをフィルターした結果を返却します。
' フィルター結果が存在はなかった場合は 空の配列 を返却します
' 第1引数 : ワークシートのデータ
' 第3引数 : 列ごとのフィルター定義リスト (フィルター不要な列については * を指定すること)
Private Function filterData(ByRef datas As Variant, ParamArray filterWords() As Variant) As Variant()
    
    ' 変数宣言
    Dim i As Long
    Dim j As Long
    Dim k As Variant
    Dim filterWordIndex As Long
    Dim filterWordMaxIndex As Long
    Dim numOfcolumn As Long
    Dim result() As Variant
    Dim isValidData As Boolean
    Dim isMatchedRowNumbers As Collection
    
    ' オブジェクトを初期化
    Set isMatchedRowNumbers = New Collection
    
    ' データの行数を取得します
    numOfcolumn = UBound(datas, 2) - LBound(datas, 2) + 1
    
    ' フィルター定義リストの最大indexを取得します
    filterWordMaxIndex = UBound(filterWords)
    
    ' 全行走査
    For i = LBound(datas, 1) To UBound(datas, 1)
        
        ' 処理対象行
        isValidData = True
        filterWordIndex = -1
        For j = LBound(datas, 2) To UBound(datas, 2)
            filterWordIndex = filterWordIndex + 1
            If filterWordMaxIndex >= filterWordIndex Then
                If filterWords(filterWordIndex) <> "*" And CStr(datas(i, j)) <> filterWords(filterWordIndex) Then
                    isValidData = False
                    Exit For
                End If
            End If
        Next
        
        ' フィルター条件に合致する行を記憶します
        If isValidData Then
            isMatchedRowNumbers.Add i
        End If
        
    Next
    
    ' 合致する結果がない場合は Empty を返却します
    If isMatchedRowNumbers.Count = 0 Then
        ReDim result(0, 0)
        filterData = result
        Exit Function
    End If
    
    ' 結果を配列に設定します
    i = 0
    ReDim result(1 To isMatchedRowNumbers.Count, LBound(datas, 2) To UBound(datas, 2))
    For Each k In isMatchedRowNumbers
        i = i + 1
        For j = LBound(datas, 2) To UBound(datas, 2)
            result(i, j) = datas(k, j)
        Next
    Next
           
    ' 結果返却
    filterData = result
    
End Function

' 二次元配列から特定の列のデータのみ取得します
' 第2引数は、例えばA列の場合は 1 を指定します
Private Function getColumnData(ByRef data As Variant, ByRef columnNumber As Long) As Collection
    
    ' 変数宣言
    Dim i As Long
    Dim result As Collection
    
    ' 結果初期化
    Set result = New Collection
    
    ' 全行走査して指定された列のデータを Collection に設定します
    For i = LBound(data, 1) To UBound(data, 1)
        result.Add data(i, columnNumber)
    Next
    
    ' 結果返却
    Set getColumnData = result
    
End Function

' 処理を実施するワークシートの文字を読み取ります
Private Function readData(ByRef targetSheet As Worksheet, Optional ByRef startFrom As String = "A1") As Variant
    
    ' 使用済みの全てのセルの値を取得します
    With targetSheet
        readData = .Range(.Range(startFrom), getLastCell(targetSheet))
    End With
    
End Function

' 配列が空であるかを判定します
Private Function IsEmptyArray(data() As Variant) As Boolean
    
On Error GoTo ERROR
        
    ' 配列のサイズを確認します
    If (0 < UBound(data, 1)) Then
        IsEmptyArray = False
    Else
        IsEmptyArray = True
    End If
    Exit Function
    
ERROR:
        
    'エラーが発生した場合は空の配列とみなします
    IsEmptyArray = True
    
End Function

' シートで使用されている最も右下のセルを取得します
Private Function getLastCell(ByRef sheet As Worksheet) As Range
    With sheet.UsedRange
        Set getLastCell = .Cells(.Cells.Count)
    End With
End Function

' Collection型から重複を排除します
Private Function removeDuplication(ByRef items As Collection) As Collection
    
    ' 変数宣言
    Dim dic As Scripting.Dictionary
    Dim result As Collection
    Dim item As Variant
    
    ' オブジェクトを初期化します
    Set dic = New Scripting.Dictionary
    Set result = New Collection
    
    ' Collectionから重複を排除します
    For Each item In items
        If Not dic.Exists(CStr(item)) Then
            dic.Add CStr(item), ""
            result.Add CStr(item)
        End If
    Next
    
    ' 結果返却
    Set removeDuplication = result
    
End Function

' Collectionの中身を標準出力します (デバック用の関数です)
Private Sub showCollectionItems(ByRef items As Collection, Optional ByRef title As String = "")
    Dim item As Variant
    If title <> "" Then
        Debug.Print title
    End If
    For Each item In items
        Debug.Print CStr(item)
    Next
End Sub

Comments

[kuta]

baseballyama様
ご回答ありがとうございます。
頂いた内容と、使用したい様に少し改修しまして、何とか実装できそうです(^^)
コードまで頂けるとは、大変助かりました。