VBA 配列にループで条件に一致したものをセル範囲ごと格納したいが、エラーが表示され正しく処理が行うことができない

Question

VBAについて勉強中の身で現在配列のところで躓いたためご質問させてください。

■やりたいこと
①L列目をループして空白だった場合
②セル範囲ごと配列に格納
③配列に格納した分を出力

■エラー発生点
上記のようにセル範囲ごと配列に格納していく処理を作成したものの、
『x(j) = arry』のところでエラーが表示され、正しく処理が行うことが出来ない状況です。

■エラー内容
実行時エラー(9)
インデックスが有効範囲にありません。

■試行した内容
エラー内容から『x(j)』の部分が正しくないのでは推察し、
『x(j,1)』に変換するなり色々試しました。

『x(j,1)』にしたところ最後まで処理は行えたものの、
A列目の情報しか抽出されませんでした。

正しく処理が行えた内容からして、
1~29列それぞれ分けて(x(j,1),x(j,2),x(j,3)・・・)
格納していく方法でないと処理できないのでしょうか？

他にセル範囲を条件に一致した分をループで格納していく方法ありましたら、
ご教授頂けないでしょうか。

Dim wb As Workbook
Set wb = ThisWorkbook

Dim ws As Worksheet
Set ws = wb.Sheets("Sheet1")

Dim sRow As Long
Dim mRow As Long
Dim arry
Dim x

'開始行
sRow = 4
'終了行
mRow = ws.Cells(Rows.Count, "B").End(xlUp).Row

j = 1

'L列目が空白の場合は配列へ格納
ReDim x(1 To mRow, 1 To 29)

For i = sRow To mRow

    arry = ws.Range(ws.Cells(i, 1), ws.Cells(i, 29))

    If Not Cells(i, 12) = "" Then
    
        x(j) = arry
        
        j = j + 1
    
    End If

Next i


'最大要素数の調整
ReDim Preserve x(1 To UBound(x), 1 To 29)

'元々セル入っていた分(A4からR最終行まで)を削除
Range("A4:AC" & mRow).ClearContents

'配列に格納している分を貼付
Range("A4:AC" & UBound(x) + 4) = x

Answer 1

ジャグ配列(配列の要素に配列を格納)として格納していって、Transposeで２次元配列にすれば可能です。

Sub Sample()

    Dim wb As Workbook
    Set wb = ThisWorkbook

    Dim ws As Worksheet
    Set ws = wb.Sheets("Sheet1")

    Dim sRow As Long
    Dim mRow As Long
    Dim arry
    Dim x

    '開始行
    sRow = 4
    '終了行
    mRow = ws.Cells(Rows.Count, "B").End(xlUp).Row

    Dim j As Long, i As Long
    j = 1

    'L列目が空白でない場合は配列へ格納
    ReDim x(1 To mRow)

    For i = sRow To mRow


        If Not Cells(i, 11) = "" Then
            arry = ws.Range(ws.Cells(i, 1), ws.Cells(i, 29))
    
            x(j) = arry
        
            j = j + 1
    
        End If

    Next i

    '最大要素数の調整
    ReDim Preserve x(1 To j - 1)

    'ジャグ配列を２次元配列に変換
    Dim y
    y = WorksheetFunction.Transpose(WorksheetFunction.Transpose(x))

    '元々セル入っていた分(A4からR最終行まで)を削除
    Range("A4:AC" & mRow).Range("A4:AC" & mRow).ClearContents

    '配列に格納している分を貼付
    Range("A4").Resize(UBound(y), UBound(y, 2)).Value = y

End Sub

ただ、jinojiさんの回答のように、最初から二次元配列にして、２重ループで１セルずつ格納していく方が分かりやすいかも。

Comments

[jinoji]

すみません。言及していただいた後に、作り替えてしまいました。
（二次元配列だとReDim Preserveがうまくいかないためです）

あと、実行した結果を改めて見てみると、
実は「ループして対象行を削除」でよかったりする？　とも思いました。

[hatena19]

あっ、気が付きませんでした。
ほとんど同じですね。

二次元配列だと最後の次元（列）しか増やせないですね。
私がする場合は、１時限目（行）を大きめにしておいて、代入するセル範囲の方で制限する方法を使います。

ReDim x(1 To mRow, 1 to 19)
For i = sRow To mRow
　　If Not Cells(i, 11) = "" Then
　　　　arry = ws.Range(ws.Cells(i, 1), ws.Cells(i, 29))
　　　　For k = 1 to 29
　　　　　　x(j, k) = arry(1, k)
　　　　Next k
　　　　j = j + 1
　　End If
Next i

Range("A4:AC" & j + 3).Value = x

Answer 2

こんな感じでどうでしょうか。

Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook

Dim ws As Worksheet
Set ws = wb.Sheets("Sheet1")

Dim sRow As Long
Dim mRow As Long
Dim arry
Dim x
Dim i, j


'開始行
sRow = 4
'終了行
mRow = ws.Cells(Rows.Count, "B").End(xlUp).Row

j = 1

'L列目が空白の場合は配列へ格納
ReDim x(1 To mRow)

For i = sRow To mRow

    arry = ws.Range(ws.Cells(i, 1), ws.Cells(i, 29))

If Not Cells(i, 12) = "" Then
        x(j) = arry
        j = j + 1
    End If

Next i


'最大要素数の調整
ReDim Preserve x(1 To j - 1)

'元々セル入っていた分(A4からR最終行まで)を削除
Range("A4:AC" & mRow).ClearContents

'配列に格納している分を貼付
Range("A4:AC" & UBound(x) + 3) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(x))

End Sub