Good Evening,

This sub worked with your sample data. It assumes that all "answers" begin with "x)" where 'x' is a letter; and that the first line of each question begins with a number. If these assumptions are incorrect, the macro may not work properly. Hope this helps,

Ben

Code:

Sub SeparateQuestions()
Dim rData As Range
Dim rQuestions As Range
Dim rAnswers As Range
Dim rCell As Range
Dim sText As String
Dim l As Long
Dim lCount As Long

'First, set values. rData is where the questions/answers are,
'rQuestions is a cell containing a heading for the questions column,
'rAnswers is a cell containing a heading for the answers column.
Set rData = Sheet2.Range("A1:A15")
Set rQuestions = Sheet2.Range("B1")
Set rAnswers = Sheet2.Range("C1")


'First, look at second digit of each rData cell to see if = ")" (answers)
For Each rCell In rData
If Mid(rCell.Value, 2, 1) = ")" Then 'Answer row
If InStr(3, rCell.Value, ")") = 0 Then
'Only one answer on row, so paste entire value to next cell
rAnswers.Offset(1, 0).Value = rCell.Value
Set rAnswers = rAnswers.Offset(1, 0)
Else
'More than one answer, so paste first answer
rAnswers.Offset(1, 0).Value = Left(rCell.Value, InStr(3, rCell.Value, ")") - 2)
'Now, truncate the string and reset the next answer cell
sText = Right(rCell.Value, Len(rCell.Value) - InStr(3, rCell.Value, ")") + 2)
Set rAnswers = rAnswers.Offset(1, 0)
'Now, count the number of times ")" occurs in the remaining text
lCount = Len(sText) - Len(Replace(sText, ")", ""))
For l = 1 To lCount 'Loop through remaining text as many times as needed
If l = lCount Then 'Last answer in cell, so just paste the remaining text
rAnswers.Offset(1, 0).Value = sText
Set rAnswers = rAnswers.Offset(1, 0)
Else 'Paste the answers and truncate remaining text for next loop
rAnswers.Offset(1, 0).Value = Left(sText, InStr(3, sText, ")") - 2)
sText = Right(sText, Len(sText) - InStr(3, sText, ")") + 2)
Set rAnswers = rAnswers.Offset(1, 0)
End If
Next
End If
End If

'Now, look at first digit to see if a number (i.e. a question)
If Left(rCell.Value, 1) < 10 And Left(rCell.Value, 1) = 0 Then
'Uncomment next line if you wish to exclude the question number
'rQuestions.Offset(1, 0).Value = Right(rCell.Value, Len(rCell..Value) _
- InStr(1, rCell.Value, "."))
'Comment next line if you wish to exclude the question number
rQuestions.Offset(1, 0).Value = rCell.Value
Set rQuestions = rQuestions.Offset(1, 0)

'Finally, append any unhandled values to last question
ElseIf Mid(rCell.Value, 2, 1) < ")" Then
rQuestions.Value = rQuestions.Value & " " & rCell.Value
End If
Next rCell

'Now that all questions and answers are done, size columns, trim and clear objects
Set rQuestions = Range(rQuestions.Address & ":" & rQuestions.End(xlUp).Address)
For Each rCell In rQuestions
rCell.Value = WorksheetFunction.Trim(rCell.Value)
Next rCell
Set rAnswers = Range(rAnswers.Address & ":" & rAnswers.End(xlUp).Address)
For Each rCell In rAnswers
rCell.Value = WorksheetFunction.Trim(rCell.Value)
Next rCell
rQuestions.EntireColumn.AutoFit
rAnswers.EntireColumn.AutoFit
Set rData = Nothing
Set rQuestions = Nothing
Set rAnswers = Nothing
Set rCell = Nothing
End Sub