2次元配列の1行目がエラーになるのを回避したい

Question

こんにちわ。

下記のような、検索プログラムを組みました。

ざっくりいうと、「検索にヒットしたら1行配列を増やして要素を入れる。」というような感じです。

困っていることは、1行目です。
下記プログラムの（Ｘ）の部分で、1行目だと二次元配列と認識されず「インデックスが有効範囲にありません」というエラーが発生します。

検索結果が1つでも要素数を2行へRedimしたら問題なく動きます。

しかし、常に空の要素が１つできてしまい保守の際さまざまな問題がでないか心配です。

この現象を回避する術はあるのでしょうか？

初心者で的外れなことを言っているかもしれませんが、なにとぞよろしくお願いいたします。

※RedimPreserve2D()はサイトからお借りしたものです。

   Sub sample()
      Dim Result As Variant '結果を入れる配列
      Dim All As Variant 'すべての配列
      Dim Hit As Long '検索ヒット数

      Hit = 0

　　　ReDim Result(1,26) 'とりあえず1行用意
      All = (別シートの10000*26のデータ）

　　　For i = 1 To 10000
        If All(i,1) = "検索ワード" '検索ワードにヒットしたらResultへ格納
           Hit = Hit + 1
　　　　　　If i <> 1 Then
              Result = RedimPreserve2D(Result,Hit)'行を1つ加算
　　　　　　End If
           For k = 1 To 26
              Result(Hit,k) = All(i,k)　'・・・（Ｘ）
           Next
        End If
      Next
   End Sub

'2次元配列の1次元目の長さを変更する関数
'orgArray … 二次元配列
'legthTo … 1次元目の長さ
   Function RedimPreserve2D(ByVal orgArray, ByVal lengthTo)
      Dim transedArray()
      transedArray = WorksheetFunction.Transpose(orgArray)
      ReDim Preserve transedArray(1 To UBound(transedArray, 1), 1 To lengthTo)
      RedimPreserve2D = WorksheetFunction.Transpose(transedArray)
   End Function
コード

Answer 1

Sub sample1()
    Dim Result As Variant '結果を入れる配列
    Dim All As Variant 'すべての配列
    Dim Hit As Long '検索ヒット数
    Hit = 0
    
    ReDim Result(1 To 1, 1 To 26) 'とりあえず1行用意
    All = (別シートの10000*26のデータ）
    
    Dim i, k
    
    For i = 1 To 10000
        If All(i, 1) = "検索ワード" Then '検索ワードにヒットしたらResultへ格納
            Hit = Hit + 1
            If Hit <> 1 Then
                Result = RedimPreserve2D(Result, Hit) '行を1つ加算
            End If
            For k = 1 To 26
                Result(Hit, k) = All(i, k) '・・・（Ｘ）
            Next
        End If
    Next
   End Sub

Sub sample2()
    Dim Result As Variant '結果を入れる配列
    Dim All As Variant 'すべての配列
    Dim Hit As Long '検索ヒット数
    Hit = 0
    
    ReDim Result(1 To 26, 1 To 1) 'とりあえず1行用意
    All = (別シートの10000*26のデータ）
    
    Dim i, k
    
    For i = 1 To 10000
        If All(i, 1) = "検索ワード" Then '検索ワードにヒットしたらResultへ格納
            Hit = Hit + 1
            If Hit <> 1 Then
               ReDim Preserve Result(1 To 26, 1 To UBound(Result, 2) + 1) '行を1つ加算
            End If
            For k = 1 To 26
                Result(k, Hit) = All(i, k) '・・・（Ｘ）
            Next
        End If
    Next
    Result = WorksheetFunction.Transpose(Result)
   End Sub

Comments

[torimuneniku]

ご回答ありがとうございます。

行と列を入れ替えれば可能ということですよね？ありがとうございます。
一度トライしてみます！

[torimuneniku]

できました！

大変助かりました・・・！！