Converting contact info in columns to rows

Microsoft Office excel 2007 plain & simp...
June 22, 2010 at 15:10:00
Specs: Windows Vista

I'm trying to sort massive amounts of grouped contact information in two columns into rows.
Currently my data looks like this:

Column A Column B
Name: Andy Park
Job Title: Attorney
Organization: Stonefield LLP
Practice Areas: Healthcare
Office: Irvine, CA
Peer Review Rating: 4.5

and the data repeats with no spaces before or after each contact. Also some contacts do not have a peer review rating.

I'm trying to organize the data so the columns have the headers (e.g. Name, Job Title, Organization, etc.) and the rows have the values (e.g. Andy Park, Attorney, etc.)

Column A(Name):Column B(Job Title)Column C(Organization):etc.
Andy Park:Attorney:Stonefield LLP:etc.

See More: Converting contact info in columns to rows

Report •

June 22, 2010 at 16:25:22

Attached is a macro which should move the data as requested into rows.

As changes made by Macros cannot be undone with the Undo button, test this macro on a copy of your data. Always make a backup of your Workbook before running this macro. This code has only been tested on sample data, and it has not been tested in your environment, so test it on copies of your data to ensure that it works 'as expected'.

As the data will be copied by the macro from a source worksheet to a destination worksheet, please name the worksheet with the source data "Source"
Select or add an empty worksheet in the same workbook and name it "Destination"
(Both sheet names are entered without the double quotes)

In the 'Source' worksheet, select 6 cells in column A containing the headings and Copy
Go to cell A1 on the 'Destination' worksheet and right-click and select 'Paste Special ...'
In the Dialog box select 'Transpose' and OK. The 6 labels will be in columns A to F

Data from any rows starting with an unrecognized label e.g. a misspelled Organziation will be placed in column G

If the Name label is missing or different e.g. "name" or " Name" or "Name "
the code will not move the destination to the next row, and two records will get merged on one line - so check your data first.
Select column A and use the AutoFilter function. Look at the drop down - there should only be 6 options.
If there are more, you have some errors in the labels - make corrections before running this code.

In the Source worksheet again, right-click the name tab and select 'View Code'
In the visual basic window that opens there should be a Project Explorer pane on the left with the "Source" worksheet name highlighted.
If the Project Explorer pane is not visible, select 'View' from the Visual Basic menu bar and select 'Project Explorer'.

Right-click the name 'Source' and select 'Insert' then choose Module (not Class Module)
Double click the new module - typically named Module1, in the Modules folder.

In the large Visual Basic code window, paste the following:

Option Explicit

Sub ResortData()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestStart As Range
Dim intRowOffst As Integer
Dim intColOffst As Integer

'On Error GoTo ErrHnd

'disable screen updating to stop flicker
Application.ScreenUpdating = False

'set start of source data
Set rngStart = Worksheets("Source").Range("A1")
'find end of source data (in column A)
Set rngEnd = Worksheets("Source"). _
            Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'set start of destination data
'note headings are in row 1
Set rngDestStart = Worksheets("Destination").Range("A2")

'set destination offset counters
intRowOffst = -1
intColOffst = 0

'loop through source data in column A
For Each rngCell In Worksheets("Source").Range(rngStart, rngEnd)
    'test for first entry in a record.
    If rngCell.Text = "Name" Then
        'increment destination row offset
        intRowOffst = intRowOffst + 1
    End If
    'set destination column offset
    Select Case rngCell.Text
        Case "Name"
        intColOffst = 0
        Case "Job Title"
        intColOffst = 1
        Case "Organization"
        intColOffst = 2
        Case "Practice Areas"
        intColOffst = 3
        Case "Office"
        intColOffst = 4
        Case "Peer Review Rating"
        intColOffst = 5
        Case Else
        intColOffst = 6
    End Select
    'copy data from column B
    rngCell.Offset(0, 1).Copy _
            Destination:=rngDestStart. _
            Offset(intRowOffst, intColOffst)
Next rngCell
're-enable screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
're-enable screen updating
Application.ScreenUpdating = True
End Sub

Click 'Save' from the Visual Basic menu bar.

Place the cursor in the Sub ResortData() line.
Make sure this is a copy worksheet or that you have a secure copy of your data.
Click the f5 function key to run the code.

Click Alt+f11 to return to the main Excel window and see if it worked.

You could use the COUNTA() function on Source -column B and on the Destination worksheet using a range starting at A2 to the last cell with data. The values should be the same.

PS you say you have massive amounts of data - the code would need a small change if you have more than 32767 records (names)

Report •

June 22, 2010 at 16:52:41
Thank you so much for the help. Your step by step instructions make it so easy to follow. However, the code is not working. I'm only getting return of the name in column G row 1 in the destination worksheet. Can you advise?

Report •

June 22, 2010 at 17:15:56

It sounds as though the fields named 'Name' do not match the word used in the code.

Go to the first Source cell containing the 'Name' label in column A.
Copy it
Use Alt+f11 to go to the VBA window and find the code in Module 1.

There are two places that use the 'Name' label

 If rngCell.Text = "Name" Then
Case "Name"

Delete the word Name between the double quotes.
With the cursor between the double quotes right-click and Paste.
Repeat for the other instance of the name label.
You may see something like this
If rngCell.Text = "Name: " Then

Also look at the other labels. The labels in the section Select Case to End Select must all match the labels used in column A.

Try running it again


Report •

Related Solutions

June 22, 2010 at 17:51:14
It's not as fancy as Humar's but it seems to get the job done.

I assume that your data starts in Sheet 1!A1 and that you already have your column headings in Sheet 2 Row 1.

Sub TransposeContacts()
Dim colNum, rowNum, putNum, nxtRow As Integer
'Initialize variables
''Sheet 2 Column Number for placing data
 colNum = 1
''Sheet 2 Row number for placing data
 putRow = 2
''Sheet 1 Row Number for loop
 nxtRow = 1
 With Sheets(1)
'Loop through Sheet 1 in groups of 6
   For rowNum = nxtRow To nxtRow + 5
'If cell is empty, we're done
    If .Cells(rowNum, 1) = "" Then Exit Sub
'If there is no PRR value, decrement row counter
'and Exit loop
     If rowNum = nxtRow + 5 And .Cells(rowNum, 1) <> _
       "Peer Review Rating" Then
         nxtRow = nxtRow - 1
         Exit For
     End If
'Place Data from Sheet 1 to Sheet 2
      Sheets(2).Cells(putRow, colNum) = .Cells(rowNum, 2)
'Increment Column number
      colNum = colNum + 1
 End With
'Increment Sheet 2 Row number for placeing data
   putRow = putRow + 1
'Reset Sheet 2 Column Number for placing data
   colNum = 1
'Increment Sheet1 Row number to start at next group of 6
   nxtRow = nxtRow + 6
'Do it all again
   GoTo nxtName
End Sub

Report •

June 22, 2010 at 21:20:02
Works perfectly!
Thank you both for your help!!!

Report •

Ask Question