Cut and Paste from 4x2 table Into One Row

Question

I have an Excel spreadsheet with answers to questions for an exam. It is set up as a series of 4x2 blocks. Each block has the 4 multiple choice answers in the first column, and then a 0 or a 1 in the column to the right indicating correct or incorrect.

I want to make a macro to take the 2nd, 3rd, and 4th answer and corresponding 0/1 cell and paste them so they end up to the right of the 1st answer in the block. I have this macro so far, which successfully edits the first answer and correctness indicator column:

Range("A2:B2").Select
Selection.Cut
Range("C1").Select
ActiveSheet.Paste
    Range("A3:B3").Select
Selection.Cut
Range("E1").Select
ActiveSheet.Paste
    Range("A4:B4").Select
Selection.Cut
Range("G1").Select
ActiveSheet.Paste

How can I change it so that it will do cells 2, 3, 4, 6, 7, 8, 10, 11, 12, etc. but skip 1, 5, 9, etc.?

Thanks!

First you are going to want to start from the bottom because you are going to be deleting rows. Also [NEVER USE SELECT](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros) — Chrismas007, Jan 27 '15 at 16:03

score 0 · Answer 1 · answered Jan 27 '15 at 16:48

Given an input of:

enter image description here

Using code:

Sub QReform()

Dim CurRow As Long, LastRow As Long

LastRow = Range("A" & Rows.Count).End(xlUp).Row

For CurRow = LastRow To 1 Step -1
    If ((CurRow - 1) / 5) - ((CurRow - 1) \ 5) = 0 Then
        Cells(CurRow, 2).Value = Cells(CurRow, 1).Offset(1, 0).Value
        Cells(CurRow, 3).Value = Cells(CurRow, 1).Offset(1, 1).Value
        Cells(CurRow, 4).Value = Cells(CurRow, 1).Offset(2, 0).Value
        Cells(CurRow, 5).Value = Cells(CurRow, 1).Offset(2, 1).Value
        Cells(CurRow, 6).Value = Cells(CurRow, 1).Offset(3, 0).Value
        Cells(CurRow, 7).Value = Cells(CurRow, 1).Offset(3, 1).Value
        Cells(CurRow, 8).Value = Cells(CurRow, 1).Offset(4, 0).Value
        Cells(CurRow, 9).Value = Cells(CurRow, 1).Offset(4, 1).Value
        Cells(CurRow, 1).Offset(4, 0).EntireRow.Delete xlShiftUp
        Cells(CurRow, 1).Offset(3, 0).EntireRow.Delete xlShiftUp
        Cells(CurRow, 1).Offset(2, 0).EntireRow.Delete xlShiftUp
        Cells(CurRow, 1).Offset(1, 0).EntireRow.Delete xlShiftUp
    End If
Next CurRow

End Sub

Will give you this:

enter image description here

score 0 · Accepted Answer · answered Jan 28 '15 at 16:09

0

I ended up moving the columns into a text editor and using regex to do the work, as that was a much simpler way of doing it. I searched for blocks of 4 lines and replaced returns with tabs where appropriate so it would fit on one line and go back into Excel easily.

answered Jan 28 '15 at 16:09

Andrew Gordon

11
3

Seems counter-productive. I didn't see any comments on my answer why it didn't work. – Chrismas007 Jan 28 '15 at 16:13

Cut and Paste from 4x2 table Into One Row

2 Answers2