Cut and Paste and Transpose


I have two columns of data

4   2

5  8

7  3

And I want to create one column where the values in the second column are below the corresponding values in the first column.  So it would look like.







I can do this by copying and pasting via transpose but I want a macro because I have a lot of data.  

Many thanks,





Paste the code below into a standard code module. None of the pre-existing code modules in a blank workbook fit that bill. You will have to add one, and its default name will be "Module1". You can change the name if you like.

Option Explicit
Enum Nwn                        ' worksheet navigation
    NwnHeaderRowsCount = 1      ' important: adjust to reality on your sheet
    Nwn1stColumn = 1            ' Columns: 1 = A
    Nwn2ndColumn                ' no value means preceding value + 1 (here = 2 = B)
End Enum
Sub MergeColumns()
    ' 28 Aug 2017
    Dim Arr As Variant          ' working array
    Dim Rng As Range            ' target range
    Dim Rl As Long              ' last row in 1st column
    Dim R As Long, i As Long    ' row / index counters
    With ActiveSheet            ' to avoid accidents, better name the sheet
        Rl = .Cells(.Rows.Count, Nwn1stColumn).End(xlUp).Row
        Arr = .Range(.Cells(NwnHeaderRowsCount + 1, Nwn1stColumn), _
                     .Cells(((Rl - NwnHeaderRowsCount) * 2 + NwnHeaderRowsCount), Nwn2ndColumn)).Value
        R = UBound(Arr)
        For i = R / 2 To 2 Step -1
            Arr(R - 1, 1) = Arr(i, 1)
            Arr(R, 1) = Arr(i, 2)
            R = R - 2
        Next i
        Arr(R, 1) = Arr(i, 2)
        Application.ScreenUpdating = False
        Set Rng = .Range(.Cells(NwnHeaderRowsCount + 1, NwnResultColumn), _
                         .Cells(UBound(Arr) + NwnHeaderRowsCount, NwnResultColumn))
        Rng.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromRightOrBelow
        Rng.Offset(0, -1).Resize(, UBound(Arr, 2)).Value = Arr
        Rng.Delete Shift:=xlToLeft
        Application.ScreenUpdating = True
    End With
End Sub

Treat the 'Enum' at the top of the code like a control panel. Specify how many header rows you have and specify 1st and 2nd columns of your numbers. Note that the macro expects them to be adjacent. You can specify a column for the result anywhere on your sheet. Its content will be over-written without warning.

If you want to follow my advice (in the remarks above) and specify the sheet on which you want the code to work, replace 'With ActiveSheet' with something like

With Worksheets("MySheet")
where "MySheet" is the sheet's name. The code would then make changes to that sheet only irrespective which sheet in which open workbook is currently active.

Answer the Question

You must create an account to use the forum. Create an Account or Login