How to loop through dimetial array using VBA in excel?

Question

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 

Answer 1

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 

Answer 2

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