Sub CLeanup()
Dim rng As Range, i As Long
Dim rng1 As Range
Set rng = Cells(Rows.Count, 1).End(xlUp)
For i = 1 To rng.Row Step 3
Cells(i, 2).Resize(1, 2).Value = _
Cells(i + 1, 1).Resize(1, 2).Value
Cells(i + 1, 1).Resize(1, 2).ClearContents
Cells(i, 4).Resize(1, 4).Value = _
Cells(i + 2, 1).Resize(1, 4).Value
Cells(i + 2, 1).Resize(1, 4).ClearContents
Next
Set rng1 = Columns(1).SpecialCells(xlBlanks)
rng1.EntireRow.Delete

End Sub

If you have formulas in the workbook, turn calculation to manual before
running.

--
Regards,
Tom Ogilvy




"Yogi_Bear_79" wrote in message
...
I have a large spreadsheet that I need to clean up.

A1
A2 B2
A3 B3 C3 D3

A1~G1

Above is arepresentation of the data. The first example is as it currently
is, the second one is what the finished product should be. I have about
9000+ rows, so need to automate it, basically each record currently takes
up
three rows