How to loop through dimetial array using VBA in excel?

I'm trying to create a file that transpose the data in on row to multiple rows and columns. Currently using an array. I can get the first row to look the way I need in order to load it into our system. I just cant get it to move to the next row of data. I tried loop but I only get the data from the first row.

Write to Sheet2 is what i need the data to look like.

Sub Test()

Dim arr() As Variant
Dim i As Long, j As Long
Dim lastRow As Long
Dim lastColumn As Long
Dim c As Long
Dim r As Long

arr = Sheet1.Range("A2").CurrentRegion

lastRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
lastColumn = Sheet2.Cells(lastRow, Columns.Count).End(xlToLeft).Column

For i = LBound(arr) To UBound(arr)

     Sheet2.Cells(lastRow, lastColumn).Value = "CADPSIHD"
     c = lastColumn + 1
     r = 2

        Sheet2.Cells(lastRow, c).Value = arr(r, 1)
        Sheet2.Cells(lastRow, c + 1).Value = arr(r, 2)
        Sheet2.Cells(lastRow, c + 2).Value = "OTH"
        Sheet2.Cells(lastRow, c + 3).Value = "CHARGE"
        Sheet2.Cells(lastRow, c + 4).Value = "STUDY"

           Call Headers
           Call Component
           Call Cost

      c = lastColumn + 3
        Dim r2 As Long
        r2 = lastRow + 1
        Sheet2.Cells(r2, c).Value = arr(r, 3)
        Sheet2.Cells(r2 + 1, c).Value = arr(r, 4)
        Sheet2.Cells(r2 + 2, c).Value = arr(r, 5)
        Sheet2.Cells(r2 + 3, c).Value = arr(r, 6)
    Next i
End Sub

Solution

When converting a large table, processing the data in an array is a more efficient approach.

Option Explicit

Sub Demo()
    Dim i As Long, j As Long, k As Long
    Dim arrData, rngData As Range
    Dim arrRes, iR As Long
    Const S_ROW = 4 ' start row#
    Const S_COL = 3 ' start col#
    Const OUT_COLS = 15 ' cols count on output sheet
    Dim ShtIn As Worksheet: Set ShtIn = Sheets("Sheet1") ' source data
    Dim LastRow As Long: LastRow = ShtIn.Cells(ShtIn.Rows.Count, "A").End(xlUp).Row
    ' get the header row of source table
    Dim aCol: aCol = ShtIn.Range("A3", ShtIn.Cells(S_ROW - 1, 1).End(xlToRight)).Value
    Dim ColCnt As Long: ColCnt = UBound(aCol, 2)
    If LastRow < S_ROW Or ColCnt < S_COL Then ' no data on source table
        MsgBox "No data"
        Exit Sub
    End If
    ' load data into an array
    Set rngData = ShtIn.Range(ShtIn.Cells(S_ROW, 1), ShtIn.Cells(LastRow, ColCnt))
    arrData = rngData.Value
    ' output array
    ReDim arrRes(1 To (LastRow - S_ROW + 1) * (ColCnt - S_COL + 2), 1 To OUT_COLS)
    ' loop through data rows
    For i = LBound(arrData) To UBound(arrData)
        iR = iR + 1
        arrRes(iR, 1) = "CAPSIHD"
        arrRes(iR, 2) = arrData(i, 1)
        arrRes(iR, 3) = arrData(i, 2)
        arrRes(iR, 4) = "OTH"
        arrRes(iR, 5) = "CHARGE"
        arrRes(iR, 6) = "STUDY"
        For k = S_COL To ColCnt
            iR = iR + 1
            For j = 1 To OUT_COLS
                Select Case j
                Case 1
                    arrRes(iR, j) = "CASIS"
                Case 2
                    arrRes(iR, j) = aCol(1, k)
                Case 3
                    arrRes(iR, j) = "Cost"
                Case Else
                    arrRes(iR, j) = arrData(i, k)
                End Select
            Next j
        Next k
    Next i
    ' write ouptut to sheet
    With Sheets("Sheet2")
        .Cells.Clear
        .Range("A15").Resize(iR, OUT_COLS).Value = arrRes
    End With
End Sub