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

Day	Count	Day	Count	Day	Count
Monday	522	Monday	365	Monday	540
Tuesday	656	Tuesday	458	Tuesday	65
Wednesday	699	Wednesday	661	Wednesday	23
Thursday	120	Thursday	874	Thursday	1051
Friday	985	Friday	321	Friday	75
Saturday	220	Saturday	987	Saturday	66
Sunday	654	Sunday	200	Sunday	24

<tbody>
</tbody>

Results I am after;

Day	Count
Monday	522
Tuesday	656
Wednesday	699
Thursday	120
Friday	985
Saturday	220
Sunday	654
Day	Count
Monday	365
Tuesday	458
Wednesday	661
Thursday	874
Friday	321
Saturday	987
Sunday	200
Day	Count
Monday	540
Tuesday	65
Wednesday	23
Thursday	1051
Friday	75
Saturday	66
Sunday	24

<tbody>
</tbody>

[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