Stack multiple columns into two columns in pairs of two

[jhicks]

I have columns A through DB (A:DB) with data, and there is a varied number of rows for each column. If possible, I need a macro that will "stack" columns in pairs of two. For example, column "C" directly under column "A" and column "D" directly under column "B" and so on for all columns A:DB.



This is an example of what my data looks like:

<code style="margin: 0px; padding: 0px; line-height: 13px; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">Row Code Price Code Price
ROW 1 2598 F800 2599 F800
ROW 2 2598 K1300 2599 K1300
ROW 3 2598 S1000 2599 R900
ROW 4 2598 G650 2599 G650
ROW 5 2598 R1200 2599 K1600
ROW 6 2599 S1000
ROW 7 2599 HP2
ROW 8 2599 R1200
Down to Row 63
.
.
</code>
This is an example of what I need the output to look like:

<code style="margin: 0px; padding: 0px; line-height: 13px; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);"> Code price
ROW 1 2598 F800
ROW 2 2598 K1300
ROW 3 2598 S1000RR
ROW 4 2598 G650
ROW 5 2598 R1200
ROW 6 2599 S1000
ROW 7 2599 HP2
ROW 8 2599 R1200
ROW 9 2599 F800
ROW 10 2599 K1300
ROW 11 2599 R900
ROW 12 2599 G650
ROW 13 2599 K1600
.</code>

 

[Leith Ross]

Hello jhicks,

Try this macro. Add a new VBA Module to your workbook and paste the code below into and then run the macro "CombineColumns".

Sub CombineColumns()


    Dim cnt     As Long
    Dim col     As Long
    Dim endA    As Long
    Dim endB    As Long
    Dim n       As Long
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = Worksheets("Sheet1")
        Set Rng = Wks.Range("A1").CurrentRegion
        
            Set Rng = Intersect(Rng, Rng.Offset(1, 0))
            endA = Rng.Cells(Rng.Rows.Count + 1, "A").End(xlUp).Row
            endB = Rng.Cells(Rng.Rows.Count + 1, "B").End(xlUp).Row
            
            For col = 3 To Rng.Columns.Count
                n = n + 1
                cnt = Rng.Cells(Rng.Rows.Count + 1, col).End(xlUp).Row
                Select Case (n And 1)
                    Case 0
                        Rng.Cells(endB, 2).Resize(cnt, 1).Value = Rng.Columns(col).Cells.Value
                        endB = endB + cnt + 1
                    Case 1
                        Rng.Cells(endA, 1).Resize(cnt, 1).Value = Rng.Columns(col).Cells.Value
                        endA = endA + cnt + 1
                End Select
            Next col
            
End Sub

 

[jhicks]

Thank you, unfortunately the macro did not work. I pasted the macro in a VBA module hit run and nothing happened.

Hello jhicks,

Try this macro. Add a new VBA Module to your workbook and paste the code below into and then run the macro "CombineColumns".

Sub CombineColumns()


    Dim cnt     As Long
    Dim col     As Long
    Dim endA    As Long
    Dim endB    As Long
    Dim n       As Long
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = Worksheets("Sheet1")
        Set Rng = Wks.Range("A1").CurrentRegion
        
            Set Rng = Intersect(Rng, Rng.Offset(1, 0))
            endA = Rng.Cells(Rng.Rows.Count + 1, "A").End(xlUp).Row
            endB = Rng.Cells(Rng.Rows.Count + 1, "B").End(xlUp).Row
            
            For col = 3 To Rng.Columns.Count
                n = n + 1
                cnt = Rng.Cells(Rng.Rows.Count + 1, col).End(xlUp).Row
                Select Case (n And 1)
                    Case 0
                        Rng.Cells(endB, 2).Resize(cnt, 1).Value = Rng.Columns(col).Cells.Value
                        endB = endB + cnt + 1
                    Case 1
                        Rng.Cells(endA, 1).Resize(cnt, 1).Value = Rng.Columns(col).Cells.Value
                        endA = endA + cnt + 1
                End Select
            Next col
            
End Sub

 

[Leith Ross]

Hello jhicks,

The macro is set for "Sheet1" in your workbook. If you don't have a worksheet named "Sheet1" the macro will do nothing.

 

[jhicks]

CodePayment Rate Code Payment Rate Code Payment Rate
1111 $50.00 1118 $50.00 1125 $50.00
1112 $51.00 1119 $51.00 1126 $51.00
1113 $52.00 1120 $52.00 1127 $52.00
1114 $53.00 1121 $53.00 1128 $53.00
1115 $54.00 1122 $54.00 1129 $54.00
1116 $55.00 1123 $55.00 1130 $55.00
1117 $56.00 1124 $56.00 1131 $56.00

This is a little bit better example

 

[Leith Ross]

Hello jhicks,

I change the macro a bit. It will now run on the active sheet. As long as the layout is from A1:DB? this will work.

Sub CombineColumns()


    Dim cnt     As Long
    Dim col     As Long
    Dim endA    As Long
    Dim endB    As Long
    Dim n       As Long
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        Set Rng = Wks.Range("A1").CurrentRegion
        
            Set Rng = Intersect(Rng, Rng.Offset(1, 0))
            endA = Rng.Cells(Rng.Rows.Count + 1, "A").End(xlUp).Row
            endB = Rng.Cells(Rng.Rows.Count + 1, "B").End(xlUp).Row
            
            For col = 3 To Rng.Columns.Count
                n = n + 1
                cnt = Rng.Cells(Rng.Rows.Count + 1, col).End(xlUp).Row - 1
                Select Case (n And 1)
                    Case 0
                        Rng.Cells(endB, 2).Resize(cnt, 1).Value = Rng.Columns(col).Cells.Value
                        endB = endB + cnt
                    Case 1
                        Rng.Cells(endA, 1).Resize(cnt, 1).Value = Rng.Columns(col).Cells.Value
                        endA = endA + cnt
                End Select
            Next col
            
End Sub

 

[Norie]

Try this, which is based on your first data set.

Sub StackStuff()
Dim arrIn()
Dim arrOut()
Dim cnt As Long
Dim I As Long
Dim J As Long

    arrIn = Range("A1").CurrentRegion
    
    For I = LBound(arrIn, 2) To UBound(arrIn, 2) Step 2
        For J = LBound(arrIn, 1) + 1 To UBound(arrIn, 1)
            If arrIn(J, I) <> "" Then
                cnt = cnt + 1
                ReDim Preserve arrOut(1 To 2, 1 To cnt)
                
                arrOut(1, cnt) = arrIn(J, I)
                arrOut(2, cnt) = arrIn(J, I + 1)
            End If
        Next J
    Next I
    
    With Range("A1").End(xlToRight).Offset(, 2)
        .Resize(, 2).Value = Array("Code", "Price")
        .Offset(1).Resize(UBound(arrOut, 2), UBound(arrOut, 1)).Value = Application.Transpose(arrOut)
    End With
    
End Sub

 

[jhicks]

Leith Ross that worked great!!!! thank you so much

Hello jhicks,

Try this macro. Add a new VBA Module to your workbook and paste the code below into and then run the macro "CombineColumns".

Sub CombineColumns()


    Dim cnt     As Long
    Dim col     As Long
    Dim endA    As Long
    Dim endB    As Long
    Dim n       As Long
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = Worksheets("Sheet1")
        Set Rng = Wks.Range("A1").CurrentRegion
        
            Set Rng = Intersect(Rng, Rng.Offset(1, 0))
            endA = Rng.Cells(Rng.Rows.Count + 1, "A").End(xlUp).Row
            endB = Rng.Cells(Rng.Rows.Count + 1, "B").End(xlUp).Row
            
            For col = 3 To Rng.Columns.Count
                n = n + 1
                cnt = Rng.Cells(Rng.Rows.Count + 1, col).End(xlUp).Row
                Select Case (n And 1)
                    Case 0
                        Rng.Cells(endB, 2).Resize(cnt, 1).Value = Rng.Columns(col).Cells.Value
                        endB = endB + cnt + 1
                    Case 1
                        Rng.Cells(endA, 1).Resize(cnt, 1).Value = Rng.Columns(col).Cells.Value
                        endA = endA + cnt + 1
                End Select
            Next col
            
End Sub

 

[Leith Ross]

Hello jhicks,

You're welcome. Glad I could help.