If the document is exactly as you describe then the following should work. It does however rely on there being the same exact number of lines for each question and answer.
Code:
Sub MarkAnswers()
Dim oRng As Range, oAns As Range
Dim iQuest As Integer, iAns As Integer
Const sNumList As String = "0123456789"
On Error GoTo lbl_Exit
For iQuest = 1 To ActiveDocument.Paragraphs.Count Step 7 'step through the questions
Set oRng = ActiveDocument.Paragraphs(iQuest).Range 'get the first paragraph of the question
oRng.MoveEnd wdParagraph, 6 'Get the last empty paragraph of the block
Set oAns = oRng.Paragraphs(6).Range 'set a range to the answer line
oAns.Collapse 1 'collapse the range to its start
oAns.MoveEndWhile sNumList 'move the end of the range to the end of the answer number
If Len(oAns.Text) > 0 Then 'if there is a number on that line
iAns = oAns.Text + 1 'add a 1 to that number - to correspond to the answer number
oRng.Paragraphs(iAns).Range.Font.ColorIndex = wdRed ' colour that paragraph red
End If
Next iQuest 'and process the next question
lbl_Exit: 'clear up
Set oRng = Nothing
Set oAns = Nothing
Exit Sub
End Sub