Stack/Combine multiple columns into one column

[MattWelsh]

Hello, I've been trying to combine multiple columns into one column for example Column C, D, E, F until columns ends, without header through VBA.

1) States remain same in its columns, but entities need to be transposed and values should be added next to entity
2) Columns may add or deleted from source
3) No empty cells in between.

Tried loop, nested but there is some error in my script.

 

[myall_blues]

You could read the values into a collection and then write out the collection.
Following code assumes source data begins in A1, outputs to J2 (allowing for headers in J1)

Option Explicit
Sub Example()
    Dim coll As New Collection
    Dim lastRow As Long, lastCol As Long, irow As Long, jcol As Long
    Dim bottomRow As Long, collRow As Long
    bottomRow = 2
    lastRow = ActiveSheet.Range("A1").End(xlDown).Row
    lastCol = ActiveSheet.Range("A1").End(xlToRight).Column
    '
    ' Read values into collection
    '
    For irow = 2 To lastRow
        For jcol = 2 To lastCol
            coll.Add ActiveSheet.Cells(irow, 1).Value
            coll.Add ActiveSheet.Cells(1, jcol).Value
            coll.Add ActiveSheet.Cells(irow, jcol).Value
        Next jcol
        '
        ' Write the collection to the output
        '
        For collRow = 1 To coll.Count Step 3
            ActiveSheet.Cells(bottomRow, 10) = coll(collRow)
            ActiveSheet.Cells(bottomRow, 11) = coll(collRow + 1)
            ActiveSheet.Cells(bottomRow, 12) = coll(collRow + 2)
            bottomRow = bottomRow + 1
        Next collRow
        '
        ' Delete/reset the collection for next row
        '
        Set coll = New Collection
    Next irow
End Sub

Regards

Murray

 

[Cubist]

This assumes your Data starts in A1 i.e. the cell labelled "State". and it's outputting to column I.

Sub StackColumn()
    Dim a, b
    Dim lastRow, lastCol As Long
    Dim ws As Worksheet
    Dim i, j, k As Long
  
    Set ws = ThisWorkbook.Worksheets("Sheet2") '<--Change sheet name as needed
    Set a = ws.Range("A1").CurrentRegion
    lastRow = a.Rows.Count - 1
    lastCol = a.Columns.Count - 1
    ReDim b(1 To lastRow * lastCol + 1, 1 To 3)
  
    k = 2
    For i = 2 To (lastRow) * (lastCol) + 1
        j = i Mod lastRow
        If j = 0 Or j = 1 Then j = j + lastRow
        If i > 2 And j = 2 Then k = k + 1
        b(i, 1) = a(j, 1)
        b(i, 2) = a(1, k)
        b(i, 3) = a(j, k)
    Next i
  
    ws.Range("I1").Resize(UBound(b, 1), 3).Value = b '<--Change output location as needed
End Sub

 

[MattWelsh]

You could read the values into a collection and then write out the collection.
Following code assumes source data begins in A1, outputs to J2 (allowing for headers in J1)

Option Explicit
Sub Example()
    Dim coll As New Collection
    Dim lastRow As Long, lastCol As Long, irow As Long, jcol As Long
    Dim bottomRow As Long, collRow As Long
    bottomRow = 2
    lastRow = ActiveSheet.Range("A1").End(xlDown).Row
    lastCol = ActiveSheet.Range("A1").End(xlToRight).Column
    '
    ' Read values into collection
    '
    For irow = 2 To lastRow
        For jcol = 2 To lastCol
            coll.Add ActiveSheet.Cells(irow, 1).Value
            coll.Add ActiveSheet.Cells(1, jcol).Value
            coll.Add ActiveSheet.Cells(irow, jcol).Value
        Next jcol
        '
        ' Write the collection to the output
        '
        For collRow = 1 To coll.Count Step 3
            ActiveSheet.Cells(bottomRow, 10) = coll(collRow)
            ActiveSheet.Cells(bottomRow, 11) = coll(collRow + 1)
            ActiveSheet.Cells(bottomRow, 12) = coll(collRow + 2)
            bottomRow = bottomRow + 1
        Next collRow
        '
        ' Delete/reset the collection for next row
        '
        Set coll = New Collection
    Next irow
End Sub

Regards

Murray

Thank you, it worked. Appreciate your help.

 

[myall_blues]

Thank you, it worked. Appreciate your help.

You’re welcome. Glad you got it sorted.