Transpose Macro

Hey all,

I don't know if it is possible to write a macro for this or not.

The data I have is ordered as follows:

Name
Company
Phone
Email

Name
Company
Phone

Name
Company
Phone
Email


Note: There aren't spaces, it was just hard to read with the it all together.

The data continues in this manner for just over 1000 people, but randomly throughout the data there are some people who I don't have a phone number or email address.

I need to have this data organized in the following manner:

Name, Company, Phone, Email.

I tried using this script, and it worked except for the fact that I didn't know how to edit it for the cases when there isn't an email address or phone number.

Sub ChrisMacro()
Dim rng As Range
Dim i As Long
Dim j As Long
Set rng = Cells(Rows.Count, 1).End(xlUp)
j = 1
For i = 1 To rng.Row Step 10
Cells(j, "B").Resize(1, 5).Value = _
Application.transpose(Cells(i, "A").Resize(6, 1))
j = j + 1
Next
End Sub

As I said I am not sure if this is possible, but any help would be greatly appreciated.

Thanks!

That's a really bad sample workbook. Most company names and phone numbers aren't considered sensitive data, and email addresses can be masked pretty simply.

To do data validation, you'll need to provide some assurances of data integrity. Email addresses are easy...pretty much any text string with an @ in it is an email address, pretty safe assumption.

But phone numbers get stored many ways. Can you verify that every phone number has dashes in it or parentheses? Can you verify your name fields do not?

I also noticed some examples of a name and phone number only. How does a macro tell the difference between a text string that is a human name and one that is a business name?

As long as there is a First Last Followed by the Company the following will work:

I didn't see any Names without a Company in the sheet I was working with.

Sub transpose()
Dim i As Long, tRow As Long, newName As String

Cells(1, 4) = "Name"
Cells(1, 5) = "Company"
Cells(1, 6) = "Phone"
Cells(1, 7) = "EMail"

i = 1
tRow = 2
Do Until Cells(i, 1) = ""
    Cells(tRow, 4) = Cells(i, 1)
    i = i + 1
    Cells(tRow, 5) = Cells(i, 1)
    i = i + 1
If Left(Cells(i, 1), 3) = "Tel" Then
    Cells(tRow, 6) = Cells(i, 1)
    i = i + 1
End If
If Left(Cells(i, 1), 5) = "Email" Then
    Cells(tRow, 7) = Cells(i, 1)
    i = i + 1
End If
tRow = tRow + 1

Loop
End Sub