Печать значений из многомерного массива

Question

У меня есть блок данных, который я определяю как диапазон ("ARRAY_DIM") в Excel. Диапазон включает в себя много данных, но также имеет много строк и столбцов без данных вообще. Ниже приведен пример определенного диапазона. Обратите внимание, что количество столбцов данных для каждого идентификатора варьируется, поэтому ARRAY_DIM определяется с помощью +100 столбцов (из которых только несколько строк будут содержать данные).

Banana  10  20  30  40  50  70
Parrot  5       1   4   30
Apple   3   3   5   6       20
Car     10  20  30  40  30
Donkey  4   12  3   0   4   5
Coconut     10      4   0   1

Я вставляю все эти данные в массив, чтобы я мог просмотреть список соответствующих идентификаторов, а затем вставить данные, связанные с идентификаторами, в соседние ячейки (та же строка). Ниже приведен упрощенный пример идентификаторов (первый столбец - это диапазон, определенный как «ВЫХОД»), и где я собираюсь вставить соответствующие данные для идентификаторов, включенных в массив.

Banana  10  20  30  40  50  70
SHARK 
Apple   3   3   5   6       20
Airplane

У меня проблемы с выполнением этой задачи на основе приведенного ниже кода. Он отлично работает для первой строки / идентификатора, но затем я получаю сообщение об ошибке «Subscript out of range» в строке вывода .Cells. Буду признателен, если кто-нибудь сможет просмотреть код и, возможно, указать на какие-либо ошибки.

Sub test()

Dim arr As Variant
Dim cell As Range

With ThisWorkbook.Sheets("Sheet1")
    arr = .Range("ARRAY_DIM")
End With

With ThisWorkbook.Sheets("Sheet2")
    For Each cell In .Range("OUTPUT")
        For x = LBound(arr, 1) To UBound(arr, 1)
            If arr(x, 1) = cell.Value Then
                For n = LBound(arr, 1) To UBound(arr, 1)
                    .Cells(cell.Row, n + 2) = arr(x, n + 1)
                Next n
            End If
        Next x
    Next cell
End With

End Sub

Answer 1

Это должно сработать, предполагая уникальные метки в первых столбцах:

Dim data As Object
Dim r As Range
Dim thisName As String
Dim thisData As Range
Set data = CreateObject("Scripting.Dictionary")


With ThisWorkbook.Sheets("Sheet1")
    ' Store each row in our Dictionary with key=item name, value=row values
    For Each r In .Range("ARRAY_DIM").Rows
        Set data(r.Cells(1).Value) = r.Resize(1, r.Columns.Count - 1).Offset(0, 1)
    Next
End With

With ThisWorkbook.Sheets("Sheet2")
    For Each r In .Range("OUTPUT").Columns(1).Cells
        thisName = r.Cells(1).Value
        ' Check if thisName exists in our Dictionary
        If data.Exists(thisName) Then
            ' Dump the data into the row if it exists
            Set thisData = data(thisName)
            r.Offset(0, 1).Resize(1, thisData.Columns.Count).Value = thisData.Value
        End If
    Next
End With

Но я думаю, что это может быть дополнительно упрощено до одного цикла:

Dim r As Range
Dim thisName As String
Dim thisData As Range
Dim outputRow As Variant
Dim outputRange as Range
Set outputRange = ThisWorkbook.Sheets("Sheet2").Range("OUTPUT")
With ThisWorkbook.Sheets("Sheet1").Range("ARRAY_DIM")
    For Each r In .Rows
        thisName = r.Cells(1).Value
        ' Check whether thisName exists in outputRange
        outputRow = Application.Match(thisName, outputRange, False)
        If Not IsError(outputRow) Then
            ' Dump this row's Values to the outputRange
            outputRange.Rows(outputRow).Value = r.Value
        End If
    Next
End With

Примечание: ни то, ни другоеиз вышеуказанных подходов добавит новую строку, если thisName не найден в диапазоне OUTPUT.