Adding column to VBA loop

Question

i currently have the code below which is pulling the Current Code image (where for each Set and # it's adding the animal), however I would like to add an new column "Color" and be able to have it do the same thing that the current code is doing just with a new column (as shown in Goal for Code Image).

I tried adding the following by I keep getting a debugging error.

output(idx, 4) = items(itemIdx, 2)

If anyone can help I would really appreacite it! Thanks :)

Current Code

Goal for Code

Const SET_NAMES_ROW_START As Long = 6
Const SET_ITEMS_ROW_START As Long = 6
Const SET_NAMES_COL As String = "A"
Const SET_ITEMS_COL As String = "E"
Const OUTPUT_ROW_START As Long = 6
Const OUTPUT_COL As String = "G"

Dim names() As Variant, items() As Variant, output() As Variant
Dim namesCount As Long, itemsCount As Long
Dim idx As Long, nameIdx As Long, itemIdx As Long

'Read the set values.
With Sheet1
    names = .Range( _
                .Cells(SET_NAMES_ROW_START, SET_NAMES_COL), _
                .Cells(.Rows.Count, SET_NAMES_COL).End(xlUp)) _
               .Resize(, 2).Value2
    items = .Range( _
                .Cells(SET_ITEMS_ROW_START, SET_ITEMS_COL), _
                .Cells(.Rows.Count, SET_ITEMS_COL).End(xlUp)) _
               .Value2
End With

'Dimension the output array.
namesCount = UBound(names, 1)
itemsCount = UBound(items, 1)

ReDim output(1 To namesCount * itemsCount, 1 To 3)

'Populate the output array.
nameIdx = 1
itemIdx = 1
For idx = 1 To namesCount * itemsCount
    output(idx, 1) = names(nameIdx, 1)
    output(idx, 2) = names(nameIdx, 2)
    output(idx, 3) = items(itemIdx, 1)
    itemIdx = itemIdx + 1
    If itemIdx > itemsCount Then
        'Increment the name index by 1.
        nameIdx = nameIdx + 1
        'Reset the item index to 1.
        itemIdx = 1
    End If
Next

'Write array to the output sheet.
Sheet1.Cells(OUTPUT_ROW_START, OUTPUT_COL).Resize(UBound(output, 1), UBound(output, 2)).Value = output

Answer 1

Sort of Unpivot

• ' *** is indicating the differences between this and the initial code.

The Code

Option Explicit

Sub SortOfUnpivot()
    
    Const FirstRow As Long = 6
    Const LastRowCol As String = "E"
    Const dstFirstCell As String = "H6"
    Dim srcCols As Variant
    srcCols = VBA.Array("A", "B", "E", "F") ' ***
    
    Dim LB As Long
    LB = LBound(srcCols)
    Dim UB As Long
    UB = UBound(srcCols)
    Dim srcCount As Long
    srcCount = UB - LB + 1
    
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, LastRowCol).End(xlUp).Row
    Dim rng As Range
    Set rng = Cells(FirstRow, LastRowCol).Resize(LastRow - FirstRow + 1)
    Dim Source As Variant
    ReDim Source(LB To UB)
    
    Dim j As Long
    For j = LB To UB
        Source(j) = rng.Offset(, Columns(srcCols(j)).Column - rng.Column).Value
    Next j
    
    Dim UBS As Long
    UBS = UBound(Source(UB))
    
    Dim Dest As Variant
    ReDim Dest(1 To UBS ^ 2, 1 To srcCount)
    Dim i As Long
    Dim k As Long
    
    For j = 1 To UBS
        k = k + 1
        For i = 1 + (j - 1) * UBS To UBS + (j - 1) * UBS
            Dest(i, 1) = Source(0)(k, 1)
            Dest(i, 2) = Source(1)(k, 1)
            Dest(i, 3) = Source(2)(i - (j - 1) * UBS, 1)
            Dest(i, 4) = Source(3)(i - (j - 1) * UBS, 1) '***
        Next i
    Next j
    
    Range(dstFirstCell).Resize(UBound(Dest), srcCount).Value = Dest

End Sub