Hi,

First make a copy of your worksheet. Second select the data and run
this macro.


Code:
--------------------
Sub ReArrangeIt()
On Error Resume Next
Dim DataArr
Application.ScreenUpdating = False
Dim iRows As Integer, iCols As Integer
iRows = Selection.Rows.Count
iCols = Selection.Columns.Count
DataArr = ActiveSheet.Range(Cells(2, 1), Cells(iRows, iCols))
ActiveSheet.Cells.ClearContents
Dim i As Integer, iCntr As Integer
iCntr = 1
For i = 1 To iRows - 1
Range("A" & iCntr) = DataArr(i, 1) 'Name
Range("C" & iCntr) = DataArr(i, 2) 'Title
Range("E" & iCntr) = DataArr(i, 7) 'Phone
iCntr = iCntr + 1
Range("A" & iCntr) = DataArr(i, 4) 'St
Range("C" & iCntr) = DataArr(i, 3) 'Facility
iCntr = iCntr + 1
Range("A" & iCntr) = DataArr(i, 5) 'City/State
Range("B" & iCntr) = DataArr(i, 6) 'Zip
iCntr = iCntr + 2
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
--------------------


--
a7n9


------------------------------------------------------------------------
a7n9's Profile: http://www.excelforum.com/member.php...o&userid=32149
View this thread: http://www.excelforum.com/showthread...hreadid=562892