Excel Macro Help

dfuhrman840 

If there is sensitive data (names, addresses and phone numbers of real people) in your file then please delete the file from your post.

Sub rearrange()

Dim i, j, k As Long

k = Range("A" & rows.Count).End(xlUp).Row * 4

For i = 2 To k

For j = 13 To 7 Step -3
If Cells(i, j).Value <> "" Then

Cells(i + 1, 1).EntireRow.Insert
Range(Cells(i + 1, 4), Cells(i + 1, 6)).Value = Range(Cells(i, j), Cells(i, j + 2)).Value
Range(Cells(i + 1, 2), Cells(i + 1, 3)).Value = Range(Cells(i, 2), Cells(i, 3)).Value

'next 3 lines are for formatting of column A, this might cause the code run significantly longer
'you can delete these 3 lines to return e.g. Plan ID 1253 instead of 001253

Cells(i, 1).Copy
Cells(i + 1, 1).PasteSpecial xlValues
Cells(i + 1, 1).PasteSpecial xlFormats

Else

End If

Next j

Next i

Application.CutCopyMode = False

End Sub

You can try this code. Lines 19 to 21 of the code are for the formatting in column A. This might cause the code to run significantly longer. If it's ok to return e.g. Plan ID 1253 instead of 001253 you can comment out these lines.