Help: How to transpose data (Complicated)

Dear All, Please help...

I have a list of contact copy from internet, but all information is in one column A1 only. I need to seperate out into A1, B1, C1, D1, E1. Is there anyway to speed up??

Example,

A1
A company
Address 1
Address 2
State, Country
Telephone
B company
Address 1
Address 2
State, Country
Telephone
C company
Address 1
Address 2
State, Country
Telephone

Now I have to copy and paste special by transpose every 5 column...
A1 B1 C1 D1 E1
A Company Address 1 Address 2 State, Country Telephone
B Company Address 1 Address 2 State, Country Telephone
C Company Address 1 Address 2 State, Country Telephone

Please help....

hi,

each company has 5 values always? no blank cells in the middle?

Thanks

Originally Posted by fredlo2010

hi,

each company has 5 values always? no blank cells in the middle?

Thanks

Yup, always 5 value and no spacing in between.. any idea?

Hi,

See if this helps. Please modify to meet your specific needs

Sub PasteTranspose()

Dim shTarget As Worksheet
Dim lRow As Long
Dim lrowTarget As Long
Dim i As Long

'create the Summary sheet
ThisWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
On Error GoTo Err1
ActiveSheet.Name = "Summary"
Set shTarget = ActiveSheet

'add the headers
Sheets("Summary").Cells(1, "A").Resize(1, 5).Value = Array("Company", "Address 1", _
                                                            "Address 2", "State, County", _
                                                            "Telephone")

'count the rows in "Sheet1" or the sheet you have the data initally
lRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

'loop through the cells and add the values
With shTarget
    For i = 1 To lRow Step 5
        'determine whats the last row the data will be going to
        lrowTarget = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                
        Sheets("Sheet1").Cells(i, "A").Resize(5, 1).Copy
        shTarget.Cells(lrowTarget, "A").PasteSpecial Transpose:=True
    Next
End With
Exit Sub

Err1:
Application.DisplayAlerts = False
    ActiveSheet.Delete
Application.DisplayAlerts = True

MsgBox "There is a sheet named: ""Summary"" in the workbook. Delete or rename to preoceed", _
        vbInformation + vbOKOnly, "Duplicate Sheet"
End Sub

Thanks