Forum Discussion

Copper Contributor

Aug 20, 2022

Solved

Copying multiple columns to two

I have 3,216 columns the odd column numbers hold the email address and the even column numbers hold the group name. I need to copy or merge the details to the first two columns. How can I do that? ...

Macros and VBA

HansVogelaar

Aug 20, 2022

Harry1605

Ah - I interpreted your request incorrectly.

If you have an insider version of Microsoft 365, there is probably a formula solution.

It might also be possible to use PowerQuery.

But here is a macro solution:

Sub Combine()
    Dim m As Long
    Dim n As Long
    Dim r As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    m = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    n = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    t = Cells(Rows.Count, 1).End(xlUp).Row + 1
    For c = 3 To n Step 2
        m = Cells(Rows.Count, c).End(xlUp).Row
        Cells(t, 1).Resize(m - 3, 2).Value = Cells(4, c).Resize(m - 3, 2).Value
        t = t + m - 3
    Next c
    Application.ScreenUpdating = True
End Sub

Harry1605

Copper Contributor

Aug 20, 2022

HansVogelaar no thats fine since:

- each cell in column A that is populated will hold 1 email address and column B will hold 1 group

So at the moment cell A has 36 cells populated from row 1 so does cell B since its the group cell A email belongs to.

Column C 34 emails need to go after the last email in column A and its equivalent group in column D goes into first empty cell in B (in this case B37) same working for remaining 3,600+ columns thanks

Column A

email address removed for privacy reasons

Column B

Group 1

HansVogelaar

MVP

Aug 20, 2022

Harry1605

Ah - I interpreted your request incorrectly.

If you have an insider version of Microsoft 365, there is probably a formula solution.

It might also be possible to use PowerQuery.

But here is a macro solution:

Sub Combine()
    Dim m As Long
    Dim n As Long
    Dim r As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    m = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    n = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    t = Cells(Rows.Count, 1).End(xlUp).Row + 1
    For c = 3 To n Step 2
        m = Cells(Rows.Count, c).End(xlUp).Row
        Cells(t, 1).Resize(m - 3, 2).Value = Cells(4, c).Resize(m - 3, 2).Value
        t = t + m - 3
    Next c
    Application.ScreenUpdating = True
End Sub

Harry1605
Copper Contributor
Aug 21, 2022
Hi Hans, just reran - problem was my side. I still had data sitting in the first two columns. Adding two blank columns at the beginning, ran the script and perfect got what I asked for. Once again thank you so much for all your support!
HansVogelaar
MVP
Aug 21, 2022
Harry1605

Which line is highlighted when you click Debug in the error message?
Harry1605
Copper Contributor
Aug 20, 2022
Hi Hans,

Thanks for the code. However, there seems to be a runtime error 1004 it says application defined or object defined error - thanks