Генератор тестов из Excel в Word

[4akk]

Добрый день.
Нужная помощь с генераторм тестов. Нашел макрос. В Excel создается список вопросов и ответов и макросом переносится в Word. Все отлично получается, но нужно сделать так, чтобы варианты ответов на вопрос брались из разных вопросов. Т.е. чтобы был 1 правильный ответ, а другие всегда разные из других вопросов.

Код макроса

Sub TestsGenerate()

' макрос генерации тестов в Word-е из Excel-я

' (КубГТУ)

' сделано в Апшеронске

 

Dim test_count As Integer 'количество тестов

Dim quest_count As Integer ' количество вопросов в тесте

Dim max_quest As Integer ' общее количество вопросов на листе

Dim list As String ' название листа в Экселе откуда брать вопросы

 

    Worksheets("AI").Activate ' активируем лист с входными и выходными данными

    ActiveCell.SpecialCells(xlLastCell).Select

    MaxString = ActiveCell.Row

    'Worksheets("0").Cells(2, 1).Value = "x"

    

    

' открываем Word

    Dim WRD

    Set WRD = CreateObject("Word.Application")

    WRD.Visible = True

    WRD.Documents.Open "C:\test.doc" ' Путь к файлу формата Microsoft Word, в который формировать варианты тестов

    

    

    test_count = 24 ' (здесь задаем количество вариантов)

    quest_count = 5 ' (здесь задаем количество вопросов в тесте)

    max_quest = 120 ' (номер максимального номера вопроса (второй столбей))

    sea = 2

    

    Randomize

    

    For i = 0 To test_count Step 1 ' цикл по количеству тестов

         WRD.Selection.Font.Size = 14

         WRD.Selection.Font.Bold = True

         WRD.Selection.TypeText Text:="Вариант  #" + CStr(i)

         WRD.Selection.Font.Bold = wdToggle

         WRD.Selection.TypeParagraph

         WRD.Selection.Font.Size = 12

         ' Ответы в Эксель

         Worksheets("0").Cells(sea, 1).Value = "Вариант " + CStr(i)

         sea = sea + 1

         

        For j = 1 To quest_count Step 1 ' цикл по количеству вопросов в тесте

            num = Int(Rnd * max_quest) + 1

            'MsgBox (num)

            ' цикл по столбцу В, чтобы найти выбранный номер вопроса

            tmp = 0

            For z = 1 To MaxString Step 1

                If (Int(Cells(z, 2).Value) = num) Then

                    'MsgBox (Cells(z, 3).Value)

                    tmp = z

                    Exit For ' вышли, запомнив z

                End If

            Next z

            ' в ыводим в Word, если найден вопрос

            If tmp = 0 Then

               str1 = "Номер вопроса не найден: " + CStr(num)

               MsgBox (str1) ' не найденный номер

            End If

            

            If tmp <> 0 Then

               WRD.Selection.Font.Bold = True

               WRD.Selection.TypeText Text:="Вопрос  #" + CStr(j)

               WRD.Selection.Font.Bold = wdToggle

               WRD.Selection.TypeParagraph

               WRD.Selection.TypeText Text:=Trim(Cells(tmp, 3).Value)

               WRD.Selection.TypeParagraph

               ' теперь цикл по количеству вариантов ответа

               For k = 1 To 4 Step 1 ' дело в том, что количество ответов может быть 2, 3 или 4

                   If (Int(Cells(tmp + k, 2).Value) = 0) Then

                       

                       WRD.Selection.TypeText Text:=Trim(Cells(tmp + k, 4).Value) + ".  " + Trim(Cells(tmp + k, 5).Value)

                       WRD.Selection.TypeParagraph

                       ' Ответы в Эксель

                       If Len(Cells(tmp + k, 1).Value) <> 0 Then

                            Worksheets("0").Cells(sea, 2).Value = j

                            Worksheets("0").Cells(sea, 3).Value = num

                            Worksheets("0").Cells(sea, 4).Value = k

                            sea = sea + 1

                       End If

                   Else

                        Exit For

                   End If

               Next k

               WRD.Selection.TypeParagraph

               

                'WRD.Selection.InsertBreak.WdBreakType.wdSectionBreakNextPage = True

                WRD.Selection.InsertBreak (WdBreakType.wdLineBreak)

            End If

        Next j

        sea = sea + 1

    Next i

 

End Sub