This should do it for you, I think all you need to change will be the two
sheet names involved.
Open your workbook, make sure there's an empty sheet in it somewhere to
receive the transposed list. Press [Alt]+[F11] to open the VB Editor and in
it, choose Insert --> Module and copy the code below and paste it into the
module. Edit the code and close the VB editor. Run it from Tools --> Macros
--> Macro and choose its name and click the [Run] button.
Sub TransposeAddressList()
'change the Const values to
'agree with the sheet names
'in your workbook
'the name of the sheet with the
'current list of names on it
Const sourceSheetName = "Sheet1"
Const firstNameRow = 1
'number of entries per address
Const groupSize = 3
'name of an empty sheet available
'to receive the transposed list
Const destSheetName = "Sheet2"
Dim srcWS As Worksheet
Dim destWS As Worksheet
Dim lastRow As Long
Dim LC As Long
Set srcWS = ThisWorkbook.Worksheets(sourceSheetName)
lastRow = srcWS.Range("A" & Rows.Count).End(xlUp).Row
Set destWS = ThisWorkbook.Worksheets(destSheetName)
For LC = 1 To lastRow Step groupSize
destWS.Range("A" & Rows.Count). _
End(xlUp).Offset(1, 0) = srcWS.Range("A" & LC)
destWS.Range("A" & Rows.Count). _
End(xlUp).Offset(0, 1) = srcWS.Range("A" & LC + 1)
destWS.Range("A" & Rows.Count). _
End(xlUp).Offset(0, 2) = srcWS.Range("A" & LC + 2)
Next
Set srcWS = Nothing
Set destWS = Nothing
MsgBox "Job Finished", vbOKOnly, "Work Completed"
End Sub
