1

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

Добрый день.
Есть список вопросов в виде теста. Есть список ответов на последней странице. Нужно любым способом автоматически отметить правильные варианты в самих вопросах. Файл прикрепил, пару ответов выделил для примера.

2

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

Файл

Post's attachments

petr_t_dfghjk.docx 40.13 Кб, 2 скачиваний с 2018-05-19 

You don't have the permssions to download the attachments of this post.

3

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

Знаете, ваша таблица супер кривая. Там в некоторых местах номер вопроса в одной ячейке с ответом, а в других - в разных (не говоря уже о ячейках разной ширины). Сразу я этого не заметил, т.к. границ таблицы нет и они малозаметны, а заметил уже когда макрос наткнулся на ошибку. Поэтому вот вам демо версия макроса, который сработает если номер вопроса и ответ будут в разных ячейках. Если надо чтобы и такие таблицы обрабатывал - надо дописать деление ячеек + перенос части текста в соседнюю.

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
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871