Copy Values from Multiple Columns to 2 Columns

[KH4W4R]

Hello All,

Firstly I would like to apologise I have asked same question on another excel forum, I am after a quick solution not trying to disrespect rules. Problem I am facing is I am using following code to copy values from multiple columns to one column.

Following code works perfect for me; No I want this code to copy values of two columns and paste them in column A:B.

Raw Data
[TABLE="width: 398"]
<tbody>[TR]
[TD]Day[/TD]
[TD]Count[/TD]
[TD]Day[/TD]
[TD]Count[/TD]
[TD]Day[/TD]
[TD]Count[/TD]
[/TR]
[TR]
[TD]Monday[/TD]
[TD]522[/TD]
[TD]Monday[/TD]
[TD]365[/TD]
[TD]Monday[/TD]
[TD]540[/TD]
[/TR]
[TR]
[TD]Tuesday[/TD]
[TD]656[/TD]
[TD]Tuesday[/TD]
[TD]458[/TD]
[TD]Tuesday[/TD]
[TD]65[/TD]
[/TR]
[TR]
[TD]Wednesday[/TD]
[TD]699[/TD]
[TD]Wednesday[/TD]
[TD]661[/TD]
[TD]Wednesday[/TD]
[TD]23[/TD]
[/TR]
[TR]
[TD]Thursday[/TD]
[TD]120[/TD]
[TD]Thursday[/TD]
[TD]874[/TD]
[TD]Thursday[/TD]
[TD]1051[/TD]
[/TR]
[TR]
[TD]Friday[/TD]
[TD]985[/TD]
[TD]Friday[/TD]
[TD]321[/TD]
[TD]Friday[/TD]
[TD]75[/TD]
[/TR]
[TR]
[TD]Saturday[/TD]
[TD]220[/TD]
[TD]Saturday[/TD]
[TD]987[/TD]
[TD]Saturday[/TD]
[TD]66[/TD]
[/TR]
[TR]
[TD]Sunday[/TD]
[TD]654[/TD]
[TD]Sunday[/TD]
[TD]200[/TD]
[TD]Sunday[/TD]
[TD]24[/TD]
[/TR]
</tbody>[/TABLE]

Results I am after;
[TABLE="width: 128"]
<tbody>[TR]
[TD]Day[/TD]
[TD]Count[/TD]
[/TR]
[TR]
[TD]Monday[/TD]
[TD]522[/TD]
[/TR]
[TR]
[TD]Tuesday[/TD]
[TD]656[/TD]
[/TR]
[TR]
[TD]Wednesday[/TD]
[TD]699[/TD]
[/TR]
[TR]
[TD]Thursday[/TD]
[TD]120[/TD]
[/TR]
[TR]
[TD]Friday[/TD]
[TD]985[/TD]
[/TR]
[TR]
[TD]Saturday[/TD]
[TD]220[/TD]
[/TR]
[TR]
[TD]Sunday[/TD]
[TD]654[/TD]
[/TR]
[TR]
[TD]Day[/TD]
[TD]Count[/TD]
[/TR]
[TR]
[TD]Monday[/TD]
[TD]365[/TD]
[/TR]
[TR]
[TD]Tuesday[/TD]
[TD]458[/TD]
[/TR]
[TR]
[TD]Wednesday[/TD]
[TD]661[/TD]
[/TR]
[TR]
[TD]Thursday[/TD]
[TD]874[/TD]
[/TR]
[TR]
[TD]Friday[/TD]
[TD]321[/TD]
[/TR]
[TR]
[TD]Saturday[/TD]
[TD]987[/TD]
[/TR]
[TR]
[TD]Sunday[/TD]
[TD]200[/TD]
[/TR]
[TR]
[TD]Day[/TD]
[TD]Count[/TD]
[/TR]
[TR]
[TD]Monday[/TD]
[TD]540[/TD]
[/TR]
[TR]
[TD]Tuesday[/TD]
[TD]65[/TD]
[/TR]
[TR]
[TD]Wednesday[/TD]
[TD]23[/TD]
[/TR]
[TR]
[TD]Thursday[/TD]
[TD]1051[/TD]
[/TR]
[TR]
[TD]Friday[/TD]
[TD]75[/TD]
[/TR]
[TR]
[TD]Saturday[/TD]
[TD]66[/TD]
[/TR]
[TR]
[TD]Sunday[/TD]
[TD]24[/TD]
[/TR]
</tbody>[/TABLE]

[COLOR=#333333]Sub test()    Dim lastCol As Long, lastRowA As Long, lastRow As Long, i As Long[/COLOR]


    'find last non empty column number'
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column


    'loop through all columns, starting from column B'
    For i = 2 To lastCol
        'find last non empty row number in column A'
        lastRowA = Cells(Rows.Count, "A").End(xlUp).Row
        'find last non empty row number in another column'
        lastRow = Cells(Rows.Count, i).End(xlUp).Row


        'copy data from another column'
        Range(Cells(1, i), Cells(lastRow, i)).Copy
        'paste data to column A'
        Range("A" & lastRowA + 1).PasteSpecial xlPasteValues


        'Clear content from another column. if you don't want to clear content from column, remove next line'
        Range(Cells(1, i), Cells(lastRow, i)).ClearContents
    Next i


    Application.CutCopyMode = False [COLOR=#333333]End Sub[/COLOR]

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG06Oct59
[COLOR="Navy"]Dim[/COLOR] oRay [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant
oRay = ActiveSheet.Range("A1").CurrentRegion
ReDim Ray(1 To UBound(oRay, 1) * UBound(oRay, 2), 1 To 2)
[COLOR="Navy"]For[/COLOR] Ac = 1 To UBound(oRay, 2) [COLOR="Navy"]Step[/COLOR] 2
    [COLOR="Navy"]For[/COLOR] Rw = 1 To UBound(oRay, 1)
        c = c + 1
        Ray(c, 1) = oRay(Rw, Ac)
        Ray(c, 2) = oRay(Rw, Ac + 1)
    [COLOR="Navy"]Next[/COLOR] Rw
[COLOR="Navy"]Next[/COLOR] Ac
ActiveSheet.Range("A1").CurrentRegion.ClearContents
Range("A1").Resize(c, 2) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Arjan77]

Sub test()

Dim lastCol As Long, lastRowA As Long, lastRow As Long, i As Long


    'find last non empty column number'
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column


    'loop through all columns, starting from column B'
    For i = 2 To lastCol / 2
        'find last non empty row number in column A'
        lastRowA = Cells(Rows.Count, "A").End(xlUp).Row
        'find last non empty row number in another column'
        lastRow = Cells(Rows.Count, 2 * i - 1).End(xlUp).Row
        If Cells(Rows.Count, 2 * i).End(xlUp).Row > lastRow Then
        lastRow = Cells(Rows.Count, 2 * i).End(xlUp).Row
        End If
        

        'copy data from another column'
        Range(Cells(1, 2 * i - 1), Cells(lastRow, 2 * i)).Copy
        'paste data to column A'
        Range("A" & lastRowA + 1).PasteSpecial xlPasteValues


        'Clear content from another column. if you don't want to clear content from column, remove next line'
        Range(Cells(1, 2 * i - 1), Cells(lastRow, 2 * i)).ClearContents
    Next i


    Application.CutCopyMode = False
    End Sub

 

[KH4W4R]

Thank you very much Mick! Amazing

 

[KH4W4R]

Thanks Arjan! Mick's already sorted the issue. Works like a charm.

 

[MickG]

You're welcome