How to loop through dimetial array using VBA in excel? - Stack Overflow

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

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

• arrays
• excel
• vba
• nested-loops

Share Improve this question Follow asked Jan 2 at 18:54 EriknmeEriknme 3722 bronze badges 2

• 2 you never increment r it always = 2 – Warcupine Commented Jan 2 at 19:01
• 1 If you pasted this data as a Mark down table you could probably entice someone (me for sure) to give you a non-vba solution using some array functions. It's not clear to me what columns G-O are doing, but it could be extended. – pgSystemTester Commented Jan 2 at 19:31

Add a comment  | 

2 Answers 2

Sorted by: Reset to default 0

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

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