Automatic Cut & Paste - Possible?

[WaukMyWay]

I have several hundred rows of data.
Of these rows, there are two rows of data per group.
I need to cut the second row and paste it to the first column to right of
the first row.
Then I need to delete that second row which was just cut.
This is to be repeated for every group of two rows in the entire column.
Please below for an example.
Can this be done?
If so, how?

Example:
A B C D
1 a1a a1b
2 a2a a2b
3 a3a a3b
4 a4a a4b
5 a5a a5b
6 a6a a6b

Want results:

A B C D
1 a1a a1b a2a a2b
3 a3a a3b a4a a4b
5 a5a a5b a6a a6b

 

[JLatham]

As always, try this out on a COPY of your workbook with the data in it, just
in case things don't go as planned.

The code below should do the trick for you. You may need to change the
value for firstRow - it should be the same as the row with the first pair of
data entries. If you have a header row, then it should be 2, and not 1.

To get the code into your workbook (the copy, remember?) -- open it up.
Press [Alt]+[F11] to open the Visual Basic editor (VBE). In the VBE menu
choose Insert then choose Module.

Copy the code below and paste it into the module, and make any change to the
code you need to. Close the VBE. Select the sheet with the data in it and
use Tools | Macro | Macros and highlight the macro name and click the [Run]
button. Shouldn't take too long.

Here's the code:

Sub TransposeAndDelete()
Const sourceColumn = "A"
Const destColumn = "C"
Const firstRow = 1 ' change to 2 if you have a header row

Dim lastRow As Long
Dim LC As Integer ' loop counter
Dim cOffset As Integer ' column offset
Dim initialColOffset As Integer

lastRow = ActiveSheet.Range(sourceColumn & _
Rows.Count).End(xlUp).Row
initialColOffset = Range(destColumn & 1).Column - _
Range(sourceColumn & 1).Column
Application.ScreenUpdating = False ' for speed
For LC = firstRow To lastRow - 1 Step 2
cOffset = initialColOffset ' reset
Range(sourceColumn & LC).Offset(0, cOffset) = _
Range(sourceColumn & LC).Offset(1, 0)
'empty out col A so we know to delete it later
Range(sourceColumn & LC).Offset(1, 0) = ""
cOffset = cOffset + 1
Range(sourceColumn & LC).Offset(0, cOffset) = _
Range(sourceColumn & LC).Offset(1, 1)
Next
For LC = lastRow To firstRow Step -1
If IsEmpty(Range(sourceColumn & LC)) Then
Range(sourceColumn & LC).EntireRow.Delete
End If
Next
Application.ScreenUpdating = True
MsgBox "All done"
End Sub