Code to cut all column values & place them under one column

panyagak

Active Member
Joined
Feb 24, 2017
Messages
299
Hi MrExcel

I have a large Excel sheet with common row
headers but with close to 12 columns with
different values. As the row headers are the same,

I need only one column under 1st of the 12 with all column values under it.

Currently, I copy the common rows & columns & paste them downwards 11 times, then cut all values in each column & paste them downwards, again 11 times so that am left with ONLY ONE column for quick sorting. ITS TIRESOME though safer for me.

How can I simplify this with a code?

HELP!!!
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Try this:
Code:
Sub MyCopyColumns()

    Dim lastCol As Long
    Dim lastRow As Long
    Dim myCol As Long
    Dim colARow As Long
    
    Application.ScreenUpdating = False
        
'   Find last column with data in row 1
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
'   Check to make sure at least two columns
    If lastCol < 2 Then Exit Sub
    
'   Loop through all columns
    For myCol = 2 To lastCol
'       Find last row in current column
        lastRow = Cells(Rows.Count, myCol).End(xlUp).Row
'       See if there is any data to copy
        If lastRow > 1 Then
'           Find first available row in column A
            colARow = Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
'           Cut and paste data
            Range(Cells(2, myCol), Cells(lastRow, myCol)).Cut Cells(colARow, "A")
        End If
    Next myCol
    
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Hi panyagak, see if this does what you want it to. Make sure that you save a copy of your original file before using this in case something goes wrong. This assumes that your row headers are in Column A, your Column headers are in Row 1 starting with Column B, and your data starts in Row 2 in each column.

Code:
Sub CopyColumns()
    Dim i%, RowLength%, RowHeaders
    
    Set RowHeaders = Range("A2", Cells(2, 1).End(xlDown))
    RowLength = Cells(Rows.Count, 1).End(xlUp).Row - 1
    For i = 3 To 13
        RowHeaders.Copy _
            Destination:=Range(Cells(Rows.Count, 1).End(xlUp).Offset(1), Cells(Cells(Rows.Count, 1).End(xlUp).Offset(1).Row + RowLength, 1))
        Range(Cells(2, i), Cells(2, i).End(xlDown)).Copy _
            Destination:=Range(Cells(Rows.Count, 2).End(xlUp).Offset(1), Cells(Cells(Rows.Count, 2).End(xlUp).Offset(1).Row + RowLength, 2))
    Next i
    Range("C1", Cells(Rows.Count, 13).End(xlUp)).ClearContents
End Sub
 
Last edited:
Upvote 0
Dear Joe4.

Kindly advise me, without appearing to violate MrExcel Message Board rules, if i can email you the raw Excel data on which my quizz is founded & then respond with accuracy & via what mode?

Is private email allowed

I'll need to attach it.

Regards
Panyagak @Nairobi
 
Upvote 0
No, that isn't really the way we do things.

You cannot upload files to this site. But there are tools you can use to post screen images. They are listed in Section B of this link here: http://www.mrexcel.com/forum/board-a...forum-use.html. Also, there is a Test Here forum on this board that you can use to test out these tools to make sure they are working correctly before using them in your question.

People have been known to upload their files to file sharing sites and provide links, but for security reasons many people are reluctant to download files off of the internet. So I would say your best bet is to pot screen images and describe your file in detail.
 
Upvote 0
Thanks Joe4.

An example is here:

Class listsABCDEFGHIJKL
Class 13.041.104.142.021.387.181.480.082.581.020.210.95
Class 21.570.011.580.222.307.483.841.783.851.792.730.97
Class 31.090.401.490.062.366.282.770.753.171.1517.000.98
Class 41.240.091.330.302.576.963.541.453.631.542.470.98
Class 57.4810.6818.167.491.069.739.5610.691.120.0133.640.98
Class 61.400.321.720.102.156.642.950.983.271.308.190.99
Class 77.4810.6818.167.491.069.739.5610.691.120.0133.640.99
Class 81.400.762.160.071.946.912.730.713.491.4712.251.00

<colgroup><col><col span="6"><col span="2"><col><col><col><col></colgroup><tbody>
</tbody>

How do you place columns values B to L to all under column A using a code, just like have done manually - copy/cut & paste downwards, for column values in columns B to C (below here)?
Class listsA
Class 13.04
Class 21.57
Class 31.09
Class 41.24
Class 57.48
Class 61.40
Class 77.48
Class 81.40
Class 11.10
Class 20.01
Class 30.40
Class 40.09
Class 510.68
Class 60.32
Class 710.68
Class 80.76
Class 14.14
Class 21.58
Class 31.49
Class 41.33
Class 518.16
Class 61.72
Class 718.16
Class 82.16

<colgroup><col><col></colgroup><tbody>
</tbody>

thanks

<colgroup><col><col span="6"><col span="2"><col><col><col><col></colgroup><tbody>
</tbody>
 
Upvote 0
Are you columns entitled A-L really in columns B-M (because aren't you Class Lists really in column A)?
 
Upvote 0
Clever Joe4, you caught me flat-footed on this one!!!!

Lets take class lists to be on column A, then next, columns B to M.

Thank you.
 
Upvote 0
Try this:
Code:
Sub MyCopyColumns()

    Dim lastCol As Long
    Dim lastRow As Long
    Dim myCol As Long
    Dim newRow As Long
    
    Application.ScreenUpdating = False
        
'   Find last column with data in row 1
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
'   Find last row with data in column A
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Check to make sure at least three columns
    If lastCol < 3 Then Exit Sub
    
'   Loop through all columns
    For myCol = 3 To lastCol
'       Find new row in column A
        newRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
'       Copy column A data down
        Range(Cells(2, "A"), Cells(lastRow, "A")).Copy Cells(newRow, "A")
'       Cut and paste data from other column
        Range(Cells(2, myCol), Cells(lastRow, myCol)).Cut Cells(newRow, "B")
    Next myCol
    
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,517
Messages
6,114,085
Members
448,548
Latest member
harryls

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top