excel - findnextを使用して、多次元配列VBAExcelに入力します

Question

私の質問は、実際には、配列内のEXCEL VBAストアの検索結果に及ぶ問題に関するものですか？

ここでAndreasは列を検索し、ヒットを配列に保存しようとしました。私は同じことを試みています。ただし、（1）値の検索（2）検索された値が検索されたのと同じ行の（3）セルから（4）2次元配列に異なる値タイプをコピーしたいという点で異なります。

したがって、配列は（概念的には）次のようになります。

Searchresult.1st SameRow.Cell1.Value1 SameRow.Cell2.Value2 SameRow.Cell3.Value3
Searchresult.2nd SameRow.Cell1.Value1 SameRow.Cell2.Value2 SameRow.Cell3.Value3
Searchresult.3rd SameRow.Cell1.Value1 SameRow.Cell2.Value2 SameRow.Cell3.Value3

Etc.

私が使用するコードは次のようになります。

Sub fillArray()

Dim i As Integer
Dim aCell, bCell As Range
Dim arr As Variant

i = 0 

Set aCell = Sheets("Log").UsedRange.Find(What:=("string"), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False, _
                    SearchFormat:=False)

If Not aCell Is Nothing Then
    Set bCell = aCell
    ReDim Preserve arr(i, 5)
    arr(i, 0) = True 'Boolean
    arr(i, 1) = aCell.Value 'String
    arr(i, 2) = aCell.Cells.Offset(0, 1).Value 
    arr(i, 3) = aCell.Cells.Offset(0, 3).Value
    arr(i, 4) = aCell.Cells.Offset(0, 4).Value
    arr(i, 5) = Year(aCell.Cells.Offset(0, 3).Value)

    i = i + 1

    Do While exitLoop = False
            Set aCell = Sheets("Log").UsedRange.FindNext(after:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                'ReDim Preserve arrSwUb(i, 5)
                    arr(i, 0) = True
                    arr(i, 1) = aCell.Value
                    arr(i, 2) = aCell.Cells.Offset(0, 1).Value
                    arr(i, 3) = aCell.Cells.Offset(0, 3).Value
                    arr(i, 4) = aCell.Cells.Offset(0, 4).Value
                    arr(i, 5) = Year(aCell.Cells.Offset(0, 3).Value)

                    i = i + 1
            Else
                exitLoop = True
            End If
    Loop


End If

End Sub

ループ内の配列を再調整するとうまくいかないようです。範囲外の添え字エラーが発生します。現在行っているようにアレイを再変更することはできないと思いますが、それがどのように行われるべきかを理解することはできません。

私が間違っていることについての手がかりがあれば、私は素晴らしいと思います。

Answer 1

ReDim Preserveは、配列の最後の次元のみのサイズを変更できます：http://msdn.microsoft.com/en-us/library/w8k3cys2(v=vs.71) .aspx

上記のリンクから：

保存

Optional. Keyword used to preserve the data in the existing array when you change the size of only the last dimension.

編集： それはそれほど役に立ちませんね。配列を転置することをお勧めします。また、配列関数からのこれらのエラーメッセージはひどいものです。

Siddarthの提案で、これを試してください。問題がある場合はお知らせください。

Sub fillArray()
    Dim i As Integer
    Dim aCell As Range, bCell As Range
    Dim arr As Variant

    i = 0
    Set aCell = Sheets("Log").UsedRange.Find(What:=("string"), _
                                             LookIn:=xlValues, _
                                             LookAt:=xlWhole, _
                                             SearchOrder:=xlByRows, _
                                             SearchDirection:=xlNext, _
                                             MatchCase:=False, _
                                             SearchFormat:=False)
    If Not aCell Is Nothing Then
        Set bCell = aCell
        ReDim Preserve arr(0 To 5, 0 To i)
        arr(0, i) = True 'Boolean
        arr(1, i) = aCell.Value 'String
        arr(2, i) = aCell.Cells.Offset(0, 1).Value
        arr(3, i) = aCell.Cells.Offset(0, 3).Value
        arr(4, i) = aCell.Cells.Offset(0, 4).Value
        arr(5, i) = Year(aCell.Cells.Offset(0, 3).Value)
        i = i + 1
        Do While exitLoop = False
            Set aCell = Sheets("Log").UsedRange.FindNext(after:=aCell)
            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                ReDim Preserve arrSwUb(0 To 5, 0 To i)
                arr(0, i) = True
                arr(1, i) = aCell.Value
                arr(2, i) = aCell.Cells.Offset(0, 1).Value
                arr(3, i) = aCell.Cells.Offset(0, 3).Value
                arr(4, i) = aCell.Cells.Offset(0, 4).Value
                arr(5, i) = Year(aCell.Cells.Offset(0, 3).Value)
                i = i + 1
            Else
                exitLoop = True
            End If
        Loop
    End If
End Sub

注：宣言では、次のようになりました。

Dim aCell, bCell as Range

これは次と同じです：

Dim aCell as Variant, bCell as Range

上記を実証するためのいくつかのテストコード：

Sub testTypes()

    Dim a, b As Integer
    Debug.Print VarType(a)
    Debug.Print VarType(b)

End Sub

Answer 2

これは、最初に配列の次元を設定できることを前提としたオプションです。「文字列」のUsedRangeでWorsheetFunction.Countifを使用しましたが、これは機能するはずです。

Option Explicit

    Sub fillArray()

    Dim i As Long
    Dim aCell As Range, bCell As Range
    Dim arr() As Variant
    Dim SheetToSearch As Excel.Worksheet
    Dim StringCount As Long

    Set SheetToSearch = ThisWorkbook.Worksheets("log")
    i = 1

    With SheetToSearch
        StringCount = Application.WorksheetFunction.CountIf(.Cells, "string")
        ReDim Preserve arr(1 To StringCount, 1 To 6)
        Set aCell = .UsedRange.Find(What:=("string"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            arr(i, 1) = True    'Boolean
            arr(i, 2) = aCell.Value    'String
            arr(i, 3) = aCell.Cells.Offset(0, 1).Value
            arr(i, 4) = aCell.Cells.Offset(0, 3).Value
            arr(i, 5) = aCell.Cells.Offset(0, 4).Value
            arr(i, 6) = Year(aCell.Cells.Offset(0, 3).Value)
            Set bCell = aCell
            i = i + 1

            Do Until i > StringCount
                Set bCell = .UsedRange.FindNext(after:=bCell)
                If Not bCell Is Nothing Then
                    arr(i, 1) = True    'Boolean
                    arr(i, 2) = bCell.Value    'String
                    arr(i, 3) = bCell.Cells.Offset(0, 1).Value
                    arr(i, 4) = bCell.Cells.Offset(0, 3).Value
                    arr(i, 5) = bCell.Cells.Offset(0, 4).Value
                    arr(i, 6) = Year(bCell.Cells.Offset(0, 3).Value)
                    i = i + 1
                End If
            Loop
        End If
    End With

    End Sub

私はあなたの宣言のいくつかの問題を修正したことに注意してください。Option Explicitを追加しました。これにより、変数を宣言する必要があります。exitLoopは宣言されていません。これで、aCellとbCellの両方が範囲になります。以前はbCellのみでした（「1つのDimステートメントで宣言された変数に注意を払う」までスクロールダウンします）。また、ワークシート変数を作成し、Withステートメントで囲みました。また、配列の両方の次元を1から始めました。なぜなら、私が推測したかったからです:)。また、ループ終了ロジックの一部を簡略化しました。いつ終了するかを指示するために、これらすべてが必要だったとは思いません。

Answer 3

Redim Preserveこのような多次元配列はできません。多次元配列では、Preserveを使用する場合、最後の次元のみを変更できます。他のディメンションのいずれかを変更しようとすると、実行時エラーが発生します。このmsdnリンクを読むことをお勧めします

私は2つのオプションを考えることができると言った

オプション1

結果を新しい一時シートに保存します

オプション2

1D配列を宣言してから、たとえば一意の区切り文字を使用して結果を連結します"#Evert_Van_Steen#"

コードの上部

Const Delim As String = "#Evert_Van_Steen#"

次に、このように使用します

ReDim Preserve arr(i)

arr(i) = True & Delim & aCell.Value & Delim & aCell.Cells.Offset(0, 1).Value & Delim & _
aCell.Cells.Offset(0, 3).Value & Delim & aCell.Cells.Offset(0, 4).Value & Delim & _
Year(aCell.Cells.Offset(0, 3).Value)