1 Тема от MarG

  • MarG
  • рядовой
  • Неактивен
  • Зарегистрирован: 17.02.2011
  • Сообщений: 8

Тема: Макрос для вставление буквы в алфавитном порядке перед каждой ответе

Всем добрый день, я с макросами так и не смог разобраться, нужна помощь… Как автоматизировать, чтоб каждом перед ответом стоял буквы, ввиде A) B) C) D) E) а эти ##Q#, ##A-#, ##A#, ##A+#, ##A# удалился
Тест создан из макроса test, вот например, в тесте указанно
##Test#НомерВопроса#СложностьВопроса#
##Q#
ТекстВопроса
##Q#
##A-#
ТекстОтвета1
##A#
##A+#
ТекстПравильногоОтвета2
##A#
##A-#
ТекстОтвета3
##A#
##A-#
ТекстОтвета4
##A#
##A-#
ТекстОтвета5
##A#

Ну, в результате выглядело бы так:
##Test#НомерВопроса#СложностьВопроса#
ТекстВопроса
A)    ТекстОтвета1
B)    ТекстПравильногоОтвета2
C)    ТекстОтвета3
D)    ТекстОтвета4
E)    ТекстОтвета5

2 Ответ от MarG

  • MarG
  • рядовой
  • Неактивен
  • Зарегистрирован: 17.02.2011
  • Сообщений: 8

Re: Макрос для вставление буквы в алфавитном порядке перед каждой ответе

    With ActiveDocument.Content.Find
        .Text = "(^0013##Q#)(*)(##Q#^0013)"
        .Forward = True
        .Wrap = wdFindContinue
        .MatchCase = True
        .MatchWildcards = True

        .Replacement.Text = "\2"
        .Replacement.Font.Bold = True
        .Execute Replace:=wdReplaceAll
    End With
    With ActiveDocument.Content.Find
        .Text = "(##A-#)(*)(##A#)"
        .Forward = True
        .Wrap = wdFindContinue
        .MatchCase = True
        .MatchWildcards = True

        .Replacement.Text = "\2"
        .Execute Replace:=wdReplaceAll
    End With
    With ActiveDocument.Content.Find
        .Text = "(##A+#)(*)(##A#)"
        .Forward = True
        .Wrap = wdFindContinue
        .MatchCase = True
        .MatchWildcards = True

        .Replacement.Text = "\2"
        .Execute Replace:=wdReplaceAll
    End With
    With ActiveDocument.Content.Find
        .Text = "^0013{2;}"
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True

        .Replacement.Text = "^p"
        .Execute Replace:=wdReplaceAll
    End With

дальше не смог нумеровать ответов, помогите

3 Ответ от Вождь

  • Макрос для вставление буквы в алфавитном порядке перед каждой ответе
  • Вождь
  • Модератор
  • Неактивен
  • Зарегистрирован: 07.01.2010
  • Сообщений: 745
  • Поблагодарили: 181

Re: Макрос для вставление буквы в алфавитном порядке перед каждой ответе

Пробуйте. Нумерация реализована с помощью списков.

Sub A()

    ' активный документ
Dim R As Word.Range

    Set R = ActiveDocument.Range(0, 0)
    
    ' удаляем ##Q#
    R.Find.Execute FindText:="##Q#^p", Replace:=wdReplaceAll
    
    ' группируем ответы: между ответами удаляем ##A-#, ##A#, ##A+#
    R.Find.Execute _
        FindText:="##A[#+\-]{1;2}^13##A[#+\-]{1;2}^13", _
        MatchWildcards:=True, _
        Replace:=wdReplaceAll
        
' нумеруем ответы
    
    ' тип нумерации
Dim LT As ListTemplate

    ListGalleries(wdNumberGallery).Reset Index:=1
    Set LT = ListGalleries(wdNumberGallery).ListTemplates(1)
    With LT.ListLevels(1)
        .NumberStyle = wdListNumberStyleUppercaseRussian
        .NumberFormat = "%1)"
    End With
    
    ' ищем группы ответов
    With R.Find
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = "##A[#+\-]{1;2}^13(*)##A[#+\-]{1;2}^13"
        .Replacement.Text = "\1"
    End With
    Do While R.Find.Execute
        ' удаляем ##A#
        R.Collapse Direction:=wdCollapseStart
        R.Find.Execute Replace:=wdReplaceOne
        ' нумеруем
        R.ListFormat.ApplyListTemplate _
            ListTemplate:=LT, _
            ContinuePreviousList:=False, _
            ApplyTo:=wdListApplyToSelection
        ' продолжаем поиск
        R.Collapse Direction:=wdCollapseEnd
    Loop
    
End Sub
Макросы под заказ и готовый пакет - mtdmacro.ru

СайтВождь

4 Ответ от MarG

  • MarG
  • рядовой
  • Неактивен
  • Зарегистрирован: 17.02.2011
  • Сообщений: 8

Re: Макрос для вставление буквы в алфавитном порядке перед каждой ответе

Спасибо, Вождь
нумерация на кириллице сойдет) я тут изменил .NumberStyle = wdListNumberStyleUppercaseRussian на English,  но получился виде цифр.

У меня еще одна последняя просьба, хотел получить (для импорта) виде:
##time 0:00:00
ТекстВопроса
-{00}ТекстОтвета1
+{00}ТекстПравильногоОтвета2
-{00}ТекстОтвета1
-{00}ТекстОтвета1
-{00}ТекстОтвета1

перед неправильной ответе вставился -{00}, а правильного ответа +{00}, но чтоб не было нумерованным (и абзац)

5 Ответ от Вождь

  • Макрос для вставление буквы в алфавитном порядке перед каждой ответе
  • Вождь
  • Модератор
  • Неактивен
  • Зарегистрирован: 07.01.2010
  • Сообщений: 745
  • Поблагодарили: 181

Re: Макрос для вставление буквы в алфавитном порядке перед каждой ответе

MarG пишет:

...изменил .NumberStyle = wdListNumberStyleUppercaseRussian на English...

English - wdListNumberStyleUppercaseLetter

MarG пишет:

последняя просьба...

Это проще:

Sub B()

    ' активный документ
Dim R As Word.Range

    Set R = ActiveDocument.Range(0, 0)
    
    ' заменяем ##Test#
    R.Find.Execute _
        FindText:="##Test#[!^13]@(^13)", _
        ReplaceWith:="##time 0:00:00\1", _
        MatchWildcards:=True, _
        Replace:=wdReplaceAll
    
    ' удаляем ##Q#
    R.Find.Execute _
        FindText:="##Q#^p", _
        ReplaceWith:="", _
        MatchWildcards:=False, _
        Replace:=wdReplaceAll
    
    ' заменяем ##A-#, ##A#, ##A+#
    R.Find.Execute _
        FindText:="##A([+\-])#^13([!^13]@^13)##A#^13", _
        ReplaceWith:="\1^123^48^48^125\2", _
        MatchWildcards:=True, _
        Replace:=wdReplaceAll
   
End Sub
Макросы под заказ и готовый пакет - mtdmacro.ru

СайтВождь

6 Ответ от MarG

  • MarG
  • рядовой
  • Неактивен
  • Зарегистрирован: 17.02.2011
  • Сообщений: 8

Re: Макрос для вставление буквы в алфавитном порядке перед каждой ответе

Большое спасибо, Вождь