VBAの2次元配列の要素数を可変にしたい

Question

Excelのdataというシートに膨大な行数（今はテスト用に100行ほど）、K列までのデータがあります。このデータから様々な条件で抽出をしたいと考えていまして、テスト用にL列にいくつか「〇」を打っています。
既存のデータを配列化し、その中で条件に合うもの（今回は12列目に〇のあるもの）を新しい2次元配列に入れなおす記述をしました。

Sub 配列化して項目で抽出テスト()
    Dim i As Long, n As Long, m As Long
    Dim x As String
    Dim buf() As Variant
    Dim cnt As Long: cnt = 1
    
    buf() = Sheets("data").Range("a2:l100").Value
    

    '新配列の縦要素数のために個数mを測定
    For n = 1 To UBound(buf(), 1)
    If buf(n, 12) = "〇" Then
    m = m + 1
    End If
    Next n
    
    '条件にあったら新配列に入れていく
    ReDim buf2(1 To m, 1 To 12)
    For n = 1 To UBound(buf(), 1)
    If buf(n, 12) = "〇" Then
        For i = 1 To 12
        buf2(cnt, i) = buf(n, i)
        Next i
        cnt = cnt + 1
    End If
    Next n

    MsgBox buf2(4, 8)
    
End Sub

うまく動いてMsgBox buf2(4, 8)もちゃんと表示されるのですが、
'新配列の縦要素数のために個数を測定
という新配列の1次元要素数を求める動きが不器用な気がします。buf2の要素数を可変にして、条件に見合う旧配列データを次々に追加する方法はないものでしょうか。

ご教示願います。

Comments

[hatena19]

「膨大な行数」というのは、最大でどのくらいのものを想定していますか。

[Izumo1101]

行数で言うと最大で5000行程度でしょうか。高速化と勉強のために配列に挑戦しています。

[hatena19]

抽出後の配列の出力先はシートですか。

[Izumo1101]

抽出後にさらに抽出はあり得ますが、最後は基本的にシートに出力するつもりです。

Answer 1

高速化が目的なら、VBAでオートフィルタを使用するのが、たぶん一番高速だと思います。

Office TANAKA - Excel VBA Tips(オートフィルタ(書き方の基本)

Office TANAKA - Excel VBA Tips(オートフィルタ(結果をコピーする))

---

配列の要素数を動的に増やすには、ReDim Preserveを使いますが、
2次元配列では増やせるのは最後の次元のみという制限があります。
ReDim Preserve buf2(r, c) だと増やせるのは c のみ。
質問の要件では増やしたいのは、r の方ですよね。

方法1
WorksheetFunction.Transpose（行列変換関数）を使うと一次元と二次元を入れ替えることでできます。まず、r, c を入れ替えて、ReDim Preserve buf2(c, r) でrを増やせることができます。
シートに出力する前にWorksheetFunction.Transposeで入れ替えてbuf2(r, c)にしてから出力します。

ただ、WorksheetFunction.Transposeには処理できる要素数の制限があるらしいです。(5000件ぐらいなら大丈夫だと思いますが)

動的2次元配列の次元を入れ替えてシートへ出力（Transpose）｜VBA技術解説

方法2
配列のサイズを想定できる最大サイズで確保しておく。
そこに条件にあう行を順に放り込んでいく。
シートに出力するときには、
出力先のセル範囲のサイズを条件に合った件数のサイズに指定して代入すれば、そのサイズ分だけ出力できる。

こちらの方がシンプルだし、高速だと思います。
ただ、余分にメモリを使うことになりますが、現在のPCの標準的なスペックなら気にする必要はないでしょう。

    ReDim buf2(1 To UBound(buf), 1 To 12)
    For n = 1 To UBound(buf)
      ・・・略
      cnt = cnt + 1
      ・・・略      
    Next n

   Sheets("Outpot").Range("A1").Resize(Cnt, 12).Value = buf2

方法3

方法2と同じ考え方ですか、配列は一つだけにして、
配列内で、条件にあう行を順に前に移動させていく。
出力は方法2と同じ方法で。

方法3のコード例

Sub 配列化して項目で抽出テスト()
    Dim i As Long, n As Long
    Dim buf() As Variant
    Dim cnt As Long: cnt = 0

    buf() = Sheets("data").Range("a2:l100").Value

    '条件にあったら前に移動
    For n = 1 To UBound(buf, 1)
        If buf(n, 12) = "〇" Then
            cnt = cnt + 1
            For i = 1 To 12
                buf(cnt, i) = buf(n, i)
            Next i
        End If
    Next n
    Sheets("output").Range("a2").Resize(cnt, 12).Value = buf
End Sub

この方法だとメモリを無駄に使うこともなく、シンプルかつ高速です。

Answer 2

Option Base 1

Sub 配列化して項目で抽出テスト()
    Dim i As Long, n As Long, m As Long
    Dim x As String
    Dim buf() As Variant
    Dim cnt As Long: cnt = 1

    buf() = Sheets("data").Range("a2:l100").Value

    Dim buf2() As Variant
    For n = 1 To UBound(buf(), 1)
        If buf(n, 12) = "〇" Then
            ReDim Preserve buf2(12, myUBound(buf2, 2) + 1)
            For i = 1 To 12
                buf2(i, UBound(buf2, 2)) = buf(n, i)
            Next i
        End If
    Next n
    
    'ReDim Preserveでは最後の次元しか変更不可なので
    '行数を固定し、列を増やして値を貯めたbuf2をここで
    '行列入れ替え
    buf3 = WorksheetFunction.Transpose(buf2)

    MsgBox buf3(2, 8)
End Sub

'UBoundでは動的配列で要素0の場合、エラーが発生するため
Function myUBound(arr() As Variant, dimension As Long)
On Error GoTo ZERO
    myUBound = UBound(arr, dimension)
    Exit Function
ZERO:
    myUBound = 0
End Function