Macro to transpose data

Hi Experts

Need a macro that will transpose the data as shown from worksheet "Raw Data" into that shown in worksheet "Formatted Data".

Need to be done via a macro as the final table has 5000 rows of data.

Thank you
transposeData.xls
Champ007Asked:
Who is Participating?
 
redmondbConnect With a Mentor Commented:
Champ007,

Correction included plus a button added and output sheet minimally formatted.

Regards,
Brian.

transposeData-V3.xls
0
 
redmondbCommented:
Champ007,

(1) Will every entry have at least a Name, Company, Email Address, Date and Title?
(2) Are there any other entries that might appear (including blank rows)?
(3) Will every entry have the same sequence in column A, i.e. Name, Company, Division (optional), Email Address, Phone No (optional) and Date?
(4) What version of Excel do you (or the user(s)) have?

Thanks,
Brian.
0
 
Champ007Author Commented:
(1) Yes
(2) No additional entries. But there may be blank rows
(3) Yes, the sequence is the same.  But as you noted, there are optional fields. These fields should be left blank in the "Formatted Data" worksheet.
(4) Excel 2007

Thanks
0
Cloud Class® Course: CompTIA Healthcare IT Tech

This course will help prep you to earn the CompTIA Healthcare IT Technician certification showing that you have the knowledge and skills needed to succeed in installing, managing, and troubleshooting IT systems in medical and clinical settings.

 
redmondbCommented:
Champ007,

Assuming that there are no surprises in your answers, this can easily be done with formulas. Have you a strong preference for a macro solution?

Thanks,
Brian.
0
 
redmondbCommented:
Champ007,

Oops, overlapping posts. The blank rows might be a problem. Let me have a think!

Regards,
Brian.
0
 
PabilioCommented:
The problem, as I see it, is not the Transpose Macro... it is easy to create if RAW sheet has ALL fields repeated, even if there is a blank space where there is Not Division or Phone Number information...

The lack of some "fields" in RAW Sheet could end having wrong entries when Transposing the data ... you could use a Search function to Paste values in Email Field if there is an @ in the names, but Not all @ means email address...

@Champ: It is possible for you to show ALL People with the same Format in RAW data ?... meaning as format, the same rows with data for each Person ?...
I'm doing this question as a formality, due that I think this is probably what you are triying to reach because you mention you have more than 5.000 rows of data...

Regards,
R.
0
 
Champ007Author Commented:
redmondb,

I actually do prefer macros. There do not seem to be very many blank rows. I could manually remove if necessary.

Thanks
0
 
redmondbCommented:
Champ007,

OK, let's see how the code below works for you.

I've made a couple of assumptions...
(1) Anything that begins with "(" is the Phone Number.
(2) Anything that contains an "@" is the Email Address.
(3) Anything that looks like a date is the Date value.

Regards,
Brian

Sub Reformat_List()
Dim xCell As Range
Dim xInputSheet As Worksheet
Dim xOutputSheet As Worksheet
Dim xLastRow As Long
Dim i As Long
Dim xName As String
Dim xCompany As String
Dim xDivision As String
Dim xEmail As String
Dim xPhone As String
Dim xTitle As String

Set xInputSheet = ActiveSheet
Set xOutputSheet = Sheets.Add
xOutputSheet.Range("A1:F1").Value = Array("Name", "Company", "Division", "Email Address", "Phone", "Title")
i = 2

xInputSheet.Activate
xLastRow = ActiveSheet.Range("A1").SpecialCells(xlLastCell).Row

For Each xCell In xInputSheet.Range("A1:A" & xLastRow)
    
    If xCell.Offset(0, 1) <> "" Then
        xName = xCell
        xTitle = xCell.Offset(0, 1)
    Else
        If xCell = "" Then
            ' Ignore blank rows
        ElseIf InStr(1, xCell, "@") > 0 Then
            xEmail = xCell
        ElseIf Left(xCell, 1) = "(" Then
            xPhone = xCell
        ElseIf IsDate(xCell) Then
            ' Ignore Date
        ElseIf xCell.Offset(-1, 1) <> "" Then
            xCompany = xCell
        Else
            xDivision = xCell
        End If
        
        If xCell.Offset(1, 1) <> "" Or xCell.Row = xLastRow Then
            xOutputSheet.Cells(i, 1) = xName
            xOutputSheet.Cells(i, 2) = xCompany
            xOutputSheet.Cells(i, 3) = xDivision
            xOutputSheet.Cells(i, 4) = xEmail
            xOutputSheet.Cells(i, 5) = xPhone
            xOutputSheet.Cells(i, 6) = xTitle
            xName = ""
            xCompany = ""
            xDivision = ""
            xEmail = ""
            xPhone = ""
            xTitle = ""
            i = i + 1
        End If
    
    End If
Next

End Sub

Open in new window

0
 
redmondbCommented:
Champ007,

Oops, it doesn't handle a blank row immediately after Name. Please replace line 36 by the following...

 
ElseIf xCompany = "" Then

Open in new window


Regards,
Brian.
0
 
Champ007Author Commented:
Very Nice!!!

Thanks Redmondb. That was an outstanding - over the top solution. Very much appreciated.
0
 
redmondbCommented:
Great! Thanks, Champ007.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.