stack multiple columns

[Urraco]

Hi

I have a lot of columns, around 400 and I'm trying to stack this columns on top of each other, making single column.
In this example I would like to stack columns 3,4,5, 6 into a single column..and columns 1 and 2 to be repeated as many times as needed.
Is there any solution to do that instead of doing it manually?
Thank you very much


this is example

Book1.xlsx
	A	B	C	D	E	F
1	1	2	3	4	5	6
2	A1	B1	1	6	11	16
3	A2	B2	2	7	12	17
4	A3	B3	3	8	13	18
5	A4	B4	4	9	14	19
6	A5	B5	5	10	15	20
Sheet1

and the result

Book1.xlsx
	A	B	C
1	1	2	3
2	A1	B1	1
3	A2	B2	2
4	A3	B3	3
5	A4	B4	4
6	A5	B5	5
7	A1	B1	6
8	A2	B2	7
9	A3	B3	8
10	A4	B4	9
11	A5	B5	10
12	A1	B1	11
13	A2	B2	12
14	A3	B3	13
15	A4	B4	14
16	A5	B5	15
17	A1	B1	16
18	A2	B2	17
19	A3	B3	18
20	A4	B4	19
21	A5	B5	20
Sheet1

 

[Joe4]

Assuming that row 1 is your header, and the data starts on row 2, try this:

Sub MyStackColumns()

    Dim lr As Long
    Dim lc As Long
    Dim c As Long
    Dim nr As Long
    
    Application.ScreenUpdating = False
    
'   Find last row in column A with data
    lr = Cells(Rows.Count, "A").End(xlUp).Row

'   Find last column in row 1 with data
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    
'   Exit if last column is less than 4 (nothing to do)
    If lc < 4 Then Exit Sub
        
'   Loop through all columns, staring with column D
    For c = 4 To lc
'       Find first available row to paste to
        nr = Cells(Rows.Count, "A").End(xlUp).Row + 1
'       Copy columns A and B
        Range("A2:B" & lr).Copy Cells(nr, "A")
'       Copy data to column C
        Range(Cells(2, c), Cells(lr, c)).Cut Range("C" & nr)
    Next c
    
    Application.ScreenUpdating = True
    
End Sub

 

[mumps]

Try:

Sub StackCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, lCol As Long, x As Long
    lCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = 4 To lCol
        Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(LastRow - 1, 2).Value = Range("A2").Resize(LastRow - 1, 2).Value
        Cells(Rows.Count, "C").End(xlUp).Offset(1).Resize(LastRow - 1, 2).Value = Cells(2, x).Resize(LastRow - 1).Value
    Next x
    Range("D1").Resize(, lCol - 3).EntireColumn.Delete
    Application.ScreenUpdating = True
End Sub

 

[Urraco]

Perfect!
Thank you very much!

Assuming that row 1 is your header, and the data starts on row 2, try this:

Sub MyStackColumns()

    Dim lr As Long
    Dim lc As Long
    Dim c As Long
    Dim nr As Long
   
    Application.ScreenUpdating = False
   
'   Find last row in column A with data
    lr = Cells(Rows.Count, "A").End(xlUp).Row

'   Find last column in row 1 with data
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
   
'   Exit if last column is less than 4 (nothing to do)
    If lc < 4 Then Exit Sub
       
'   Loop through all columns, staring with column D
    For c = 4 To lc
'       Find first available row to paste to
        nr = Cells(Rows.Count, "A").End(xlUp).Row + 1
'       Copy columns A and B
        Range("A2:B" & lr).Copy Cells(nr, "A")
'       Copy data to column C
        Range(Cells(2, c), Cells(lr, c)).Cut Range("C" & nr)
    Next c
   
    Application.ScreenUpdating = True
   
End Sub

 

[Joe4]

You are welcome.
Glad we were able to help!