Выделение правильных ответов в тесте

Sub Ответы_выделить()
'vbadevelope@yandex.ru для wordexpert.ru
'Выделяет правильные ответы жёлтым цветом, сверяясь с таблицей ответов
'Условия: 1)Одна таблица в документе (таблица с ответами);
'         2)Чётное количество столбцов в таблице (Ячейка 1:номер вопроса - Ячейка2: ответ)
'         3)Номера вопросов и ответов имеют формат "число."
'         4)Варианты ответов в таблицах приведены через ", " (запятая + пробел)
Dim sAnswer
Dim oDoc As Document
Set oDoc = ActiveDocument
Dim oPar As Paragraph
Dim sNumb As String
Dim iCount As Integer
Dim bQuest As Boolean
Dim bArray As Boolean
bQuest = False
For Each oPar In oDoc.Paragraphs
    oPar.Range.Select
    If oPar.Range.Information(wdWithInTable) = False And oPar.Range.Font.Bold = True Then
        bArray = False
        sNumb = Left(oPar.Range.Text, InStr(oPar.Range.Text, Chr(46)))
        If sNumb = "" Then sNumb = oPar.Range.ListFormat.ListValue
        sAnswer = SelectAnswer(sNumb, oDoc)
            If InStr(sAnswer, ",") >= 1 Then
                sAnswer = Split(sAnswer, ", ")
                bArray = True
                iCount = 0
            End If
        bQuest = True
    ElseIf oPar.Range.Information(wdWithInTable) = False And bQuest = True Then
        If oPar.Range.ListFormat.ListType = 0 Then
            sLeft = Left(oPar.Range.Text, InStr(oPar.Range.Text, ")") - 1)
        Else
            sLeft = CStr(oPar.Range.ListFormat.ListValue)
        End If
        If bArray = False Then
            If sLeft = sAnswer Then
                oPar.Range.HighlightColorIndex = wdYellow
                bQuest = False
            End If
        Else
            For i = LBound(sAnswer) To UBound(sAnswer)
                If sLeft = sAnswer(i) Then
                    oPar.Range.HighlightColorIndex = wdYellow
                    iCount = iCount + 1
                    If iCount = UBound(sAnswer) + 1 Then bQuest = False
                    GoTo SkipParagraph
                End If
            Next i
        End If
    End If
SkipParagraph:
Next oPar
End Sub
Function SelectAnswer(ByVal sNumb As String, ByRef oDoc As Document)
Dim oTable As Table
Dim oCell As Cell
Dim iRowInd As Integer
For Each oCell In oDoc.Tables(1).Range.Cells
    oCell.Select
    If oCell.ColumnIndex Mod 2 <> 0 Then
        If InStr(oCell.Range.Text, "Ответы к разделу") >= 1 Then
        ElseIf Left(oCell.Range.Text, InStr(oCell.Range.Text, Chr(46)) - 1) = sNumb Then
            oCell.Select
            Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
            SelectAnswer = Replace(Replace(Selection.Range.Cells(2).Range.Text, Chr(13), ""), Chr(7), "")
            Exit Function
        End If
    End If
Next oCell
End Function