Need Macro help to move data around

[coloradobu]

Hi - Thanks for this site, I have my addresses in a nice column:

1. LastName, FirstName
2. 123 Main Street
3. City, State, Zip USA
4.
5. LastName, FirstName
6. 345 South Street
7. City, State, Zip USA

Now the department wants the format changed to attributes per column:

1. Last Name | 123 Main Street | Apt/Lot/Unit | City | State | Zip
2. Last Name | 345 South Street | Apt/Lot/Unit | City | State | Zip


Is there a way to create a macro to transpose the data rather than me doing this one name group at a time?

Thanks in advance for your help! Need this ASAP, of course.

 

[venkat1926]

the cells in 4th 8th 12 th etc rows are blank in clolumn A of your main data base in sheet1. copy data in sheet1 in sheet 3 repeat sheet3 from A1.

now try this macro and see sheet 2

Sub test()
Dim j As Long, lastname As String, street As String, city As String, state As String, zzip As String
Dim dest As Range
With Worksheets("sheet1")
j = 1
Do
lastname = Left(.Cells(j, 1), Len(.Cells(j, 1)) - WorksheetFunction.Search(",", .Cells(j, 1)) - 1)


lastname = Trim(lastname)
'MsgBox lastname
street = .Cells(j + 1, 1)
    .Cells(j + 2, 1).TextToColumns Destination:=.Cells(j + 2, 1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=True, OtherChar:= _
        ".", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
        TrailingMinusNumbers:=True
city = Trim(.Cells(j + 2, 1))
state = Trim(.Cells(j + 2, 2))
zzip = Trim(.Cells(j + 2, 3))
With Worksheets("sheet2")
Set dest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
dest = lastname
dest.Offset(0, 1) = street
dest.Offset(0, 2) = city
dest.Offset(0, 3) = state
dest.Offset(0, 4) = zzip
End With
j = j + 4
If .Cells(j, 1) = "" Then Exit Do
Loop
End With
With Worksheets("sheet2")
Range(.Range("A1"), .Range("G1")).EntireColumn.AutoFit
End With

End Sub

Sub undo()
With Worksheets("sheet2")
.Cells.Clear
End With
Worksheets("sheet1").Cells.Clear
Worksheets("sheet3").Cells.Copy Worksheets("sheet1").Range("A1")
Worksheets("sheet1").Activate
Range("A1").Select
End Sub