Используйте findnext для заполнения многомерного массива VBA Excel

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.

Изменить: Это не очень полезно, не так ли. Предлагаю вам транспонировать ваш массив. Кроме того, сообщения об ошибках от функций массива УЖАСНЫЕ.

По предложению Сиддарта попробуйте это. Сообщите мне, если у вас возникнут проблемы:

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

Вот вариант, который предполагает, что вы можете измерить массив в начале. Я использовал WorsheetFunction.Countif в UsedRange для «строки», которая, похоже, должна работать:

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 (прокрутите вниз до «Pay Внимание к переменным заявлено одним тусклым заявлением »). Я также создал переменную рабочего листа и заключил ее в оператор With. Кроме того, я начал оба измерения массива с 1, потому что ... ну, потому что я хотел, наверное :). Я также упростил логику выхода из цикла - не думаю, что вам все это нужно, чтобы сказать, когда выходить.

Вы не можете Redim Preserve создать такой многомерный массив. В многомерном массиве вы можете изменить только последнее измерение при использовании Preserve. Если вы попытаетесь изменить любое из других измерений, произойдет ошибка времени выполнения. Я бы рекомендовал прочитать эту ссылку msdn

сказав, что я могу придумать 2 варианта

Вариант 1

Сохраните результаты в новом временном листе

Вариант 2

Объявите одномерный массив, а затем объедините результаты, используя уникальный разделитель, например "#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)