Thanks..It works and I like to apply to my Excel worksheet which has 7800
rows and 192 columns. I need to apply this to five of the multiple answer
questions.

I used your code to test on my example, the last column "Q4" cells offset 2
columns to the right. Also if I do not want to delete the blank rows in
between the member id as there are alot of linked cell in the worksheet and
it may upset the linkage.

Also I wonder if it is easy to make it works on more than one multiple
answer questions using this code.

Thanks
"Trevor Shuttleworth" wrote in message
...
Paul

try this:

Sub ReformatData()

Dim LastRow As Long
Dim i As Long
Dim BaseRange As Range
Dim DeleteStack As Range

LastRow = Range("C65536").End(xlUp).Row

Range("C1") = "car"
Range("D1") = "plane"
Range("E1") = "boat"
Range("F1") = "people"
Range("G1") = "Q4"

For i = 2 To LastRow
If Range("A" & i).Value < "" Then
' remember which row to store the data
Set BaseRange = Range("A" & i)
' and make some space for it
Range("D" & i).Resize(1, 3).Insert shift:=xlToRight
' move the data to the base row
Select Case Range("C" & i)
Case "car": BaseRange.Offset(0, 2).Value = "car"
Case "plane": BaseRange.Offset(0, 3).Value = "plane": _
BaseRange.Offset(0, 2).Value = ""
Case "boat": BaseRange.Offset(0, 4).Value = "boat": _
BaseRange.Offset(0, 2).Value = ""
Case "people": BaseRange.Offset(0, 5).Value = "people": _
BaseRange.Offset(0, 2).Value = ""
End Select
Else
' stack up the rows to delete later
If DeleteStack Is Nothing Then
Set DeleteStack = Range("A" & i)
Else
Set DeleteStack = Union(DeleteStack, Range("A" & i))
End If
' move the data to the base row
Select Case Range("C" & i)
Case "car": BaseRange.Offset(0, 2).Value = "car"
Case "plane": BaseRange.Offset(0, 3).Value = "plane"
Case "boat": BaseRange.Offset(0, 4).Value = "boat"
Case "people": BaseRange.Offset(0, 5).Value = "people"
End Select
End If
Next 'i

If Not DeleteStack Is Nothing Then
DeleteStack.EntireRow.Delete
End If

End Sub

It's very specific, based on your data so it's not very scaleable ... but
if it does what you want.

Hopefull, it will give you an approach.

Regards

Trevor


"Paul" wrote in message
...
With the format of the Excel worksheet as follow:
memberID----Q1-------*Q2-------Q4
123456 yes car yes
plane
people
234578 no boat no
people
784528 yes car yes
boat

I want to transform it to the following format:
memberID----Q1----car----plane----boat----people----Q4
123456 yes car plane people yes
234578 no boat people
no
784529 yes car boat yes

The following is the code I created, somehow I can't figure out how to
set the end range to the next member ID for the 'InnerNumRows"
Sub Test()
Dim x As Integer
Dim y As Integer
' Set numrows = number of rows of data, use the column with the
maximum of rows.
NumRows = Range("C2", Range("C2").End(xlDown)).Rows.Count
Debug.Print NumRows
' Select first line of data.
Range("A2").Select
For x = 1 To NumRows
' Number of rows to the next member ID.
InnerNumRows = Range(ActiveCell, ActiveCell.Next(4)).Rows.Count
Debug.Print InnerNumRows
For y = 1 To InnerNumRows
' Check active cell for search value.
Select Case ActiveCell.Offset(0, 2).Value
Case "car"
ActiveCell.Offset(0, 2).Cut
Destination:=ActiveCell.Offset(1 - y, 2)
Case "plane"
ActiveCell.Offset(0, 2).Cut
Destination:=ActiveCell.Offset(1 - y, 3)
Case "boat"
ActiveCell.Offset(0, 2).Cut
Destination:=ActiveCell.Offset(1 - y, 4)
Case "people"
ActiveCell.Offset(0, 2).Cut
Destination:=ActiveCell.Offset(1 - y, 5)
End Select
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Next
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next

End Sub

Thanks