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

        oAns.End = oAns.Paragraphs(1).Range.End - 1
        oAns.Text = ""
    Next iQuest    'and process the next question

Sub ClearBlanks()
Dim oPara As Paragraph
    On Error Resume Next
    For Each oPara In ActiveDocument.Paragraphs
        If Len(oPara.Range) = 1 Then If Len(oPara.Range.Next.Paragraphs(1).Range) = 1 Then oPara.Range.Delete
    Next oPara
lbl_Exit:
    Exit Sub
End Sub