I have a block of data which I define as a range (“ARRAY_DIM”) in excel. The range includes a lot of data but also have many rows and columns with no data at all. Below is an example of the defined range. Please note that the number of data columns for each identifier varies which is why the ARRAY_DIM is defined with +100 columns (of which only few rows will contain data).
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
I am inserting all of this data into an array such that I can loop through a list of relevant identifiers and then paste the data associated with the identifiers in the adjacent cells (same row). See below for a simplified example of identifiers (first column is a range defined as “OUTPUT”) and where I intend to paste the relevant data for identifiers that are included in the array.
Banana 10 20 30 40 50 70 SHARK Apple 3 3 5 6 20 Airplane
I am having troubles with accomplishing this task based on the code below. It works fine for the first row/identifier but then I get an error “Subscript out of range” at the .Cells output line. I would appreciate if someone can review the code and maybe point out any errors.
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
This should handle it, assuming unique labels in the first columns:
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
But I think that can be further simplified to a single loop:
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
NB: Neither of the above approaches will add a new row if the
thisName isn’t found in the OUTPUT range.