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

This simple and efficient subroutine should help you:

Option Explicit

Sub Test()
  Dim src As Range, rc&, cc&, i&, cr&, header
  Dim tgt As Range, tc&, cols, hl&
  header = Array("CAPSIHD", "", "", "OTH", "CHARGE", "STUDY")
  hl = UBound(header) - LBound(header) + 1
  Set src = Sheet1.[A2].CurrentRegion: cr = 3
  rc = src.Rows.Count - 2: cc = src.columns.Count - 2
  cols = Application.Transpose(src.Cells(2, 3).Resize(1, cc))
  Set tgt = Sheet2.[A15]: tc = tgt.Column
  tgt.Resize(rc * (cc + 1), 1) = "CASIS"
  tgt.Offset(0, 2).Resize(rc * (cc + 1), 1) = "COST"
  With tgt.Worksheet
    For i = tgt.Row To (rc - 1) * (cc + 1) + tgt.Row Step cc + 1
      .Cells(i, tc).Resize(1, hl) = header
      .Cells(i, tc + 1).Resize(1, 2) = src.Cells(cr, 1).Resize(1, 2).Value
      .Cells(i + 1, tc + 1).Resize(cc, 1) = cols
      .Cells(i + 1, tc + 3).Resize(cc, 12) = _
        Application.Transpose(src.Cells(cr, 3).Resize(1, cc))
      cr = cr + 1
    Next
  End With
End Sub