Обработка текста

[StillFree]

Доброго всем времени суток =)
У меня к вам огромная просьба, мне нужно за короткое время обработать огромное количество текста т.е. к примеру 1ДЕк.doc сделать из него текст в виде 1ДЕ111.doc, т.е. чтобы после вопроса, непосредсвенно шел ответ т.е. то что идет в в вопросе под номером 4 с знаком плюс, Скажите есть ли малейшая возможность сделать подобный макрос?! заранее ОГРОМНОЕ СПАСИБО!

[Sasha_Smirnov]

Sub Squeezer() ' Макрос создан 19.06.2009 Customer
    
    Const Vn = 4                'количество вариантов ответа на вопрос'
    Dim QAn As String           'строка для вопроса и ответа'
    Dim Juice As String         'строка с результатом'
    Dim k As Byte, pattern As String
    
    For k = 1 To Vn: pattern = pattern & "*^13": Next
    
    'Преобразуем таблицу(-ы) активного документа в табулированный текст.'
    With ActiveDocument.Tables
    For k = 1 To .Count: .Item(k).ConvertToText (vbTab): Next
    End With
    
    Selection.HomeKey wdStory 'кусор в начало
    'Выделяем по Vn+1 непустых абзацев, идущих подряд сразу за переводом строки (^l).'
    With Selection
                .Find.Text = "^l[!^l]@^13" & pattern
                .Find.MatchWildcards = True
                .Find.Wrap = wdFindStop
                
            Do While .Find.Execute
                MsgBox Mid(.Range.Paragraphs(1), InStr(.Range.Paragraphs(1), Chr(11)) + 1)
                QAn = .Text
                If InStr(QAn, "+") = 0 Then MsgBox "Ответ на этот вопрос не отмечен."
            Loop
    End With
    
End Sub

Вам осталось к содержимому первого MsgBox’а прицепить строчку с плюсиком (если таковая имеется) и затем сохранить всё это в строке Juice!

[viter.alex]

Предложу свой вариант. Макрос работает анализируя содержимое основной таблицы. Таблицы с ответами являются вложенными по отношению к таблице с вопросами. На этом и построен макрос.

Sub GetAnswers()
  Application.ScreenUpdating = False
  Dim oResDoc As Document
  Dim oQuestTbl As Table 'Общая таблица с вопросами
  Dim oAnsTbl As Table 'Вложенная таблица с ответами
  Dim oCell As Cell 'Переменная для перебора ячеек в таблице с вопросами
  Dim oQuestStr As Range 'Строка с вопросом
  Dim oAnsStr As Range 'Строка с ответом
  Set oQuestTbl = Selection.Tables(1)
  Set oResDoc = Documents.Add
  For Each oCell In oQuestTbl.Range.Cells
    If oCell.Tables.Count <> 0 Then 'Ищем ячейку, в которой есть вложенная таблица
      Set oAnsTbl = oCell.Tables(1)
      'Ищем формулировку вопроса
      With oCell.Range.Find
        .Text = "^11*^13"
        .MatchWildcards = True
        .Forward = False
        .Execute
        If .Found Then
          Set oQuestStr = .Parent
          oQuestStr.SetRange oQuestStr.Start + 1, oQuestStr.End - 1
        End If
      End With
      'Ищем знак плюс в ячейках последнего столбца таблицы с ответами
      Dim i As Long
      For i = 1 To oAnsTbl.Rows.Count
        If Left(oAnsTbl.Cell(i, oAnsTbl.Columns.Count).Range.Text, 1) = "+" Then
          Set oAnsStr = oAnsTbl.Cell(i, oAnsTbl.Columns.Count - 1).Range
          Exit For
        End If
      Next i
      'Вставляем текст в новый документ
      oResDoc.Range.InsertAfter oQuestStr.Text & " "
      With oResDoc.Range(oResDoc.Range.End - 2, oResDoc.Range.End - 1)
        .Font.Bold = True
        .Text = oAnsStr.Text
      End With
    End If
  Next
  Application.ScreenUpdating = True
End Sub

Макрос не дуракоустойчивый. Никаких обработок ошибок пока нет. Чтобы он работал нужно поставить курсор в основную таблицу в любую ячейку. По окончании работы макроса будет создан новый документ, в котором после формулировки вопроса в том же абзаце будет жирным шрифтом следовать ответ.
Пожелания принимаются.

[StillFree]

Спасибо Всем, уже решил задачу =) можно удалять Тему

[viter.alex]

Сообщение от StillFree

Спасибо Всем, уже решил задачу =) можно удалять Тему

Интересный вы человек. Хоть решение приведите, а то как-то нечестно получается.
Или задача решилась снятием с повестки дня?

[Sasha_Smirnov]

Не только так, как сделал топикстартер, но и...

Sub SqueezerOfJuice() ' Макрос создан 21.06.2009 Customer'
    
    Const Qvariants = 4                                     'количество вариантов ответа на вопрос'
    Dim strQ As String, strA As String, juice As String  'строки для вопроса, ответа и результата'
    Dim k As Integer, stencil As String
    Dim nQ As Integer, nA As Integer 'номер вопроса и его ответа (помеченного в таблице знаком +)'
    
    For k = 1 To Qvariants: stencil = stencil & "*^13": Next 'кусок шаблона для поиска строк'
    
    ActiveDocument.Tables.Item(1).ConvertToText vbTab 'преобразуем таблицу в табулированный текст'
    
    Selection.HomeKey wdStory 'кусор - в начало'
    
    'Выделяем по 1+Qvariants непустых абзацев, идущих подряд сразу за переводом строки (код ^11).'
    With Selection
        .Find.Text = "^11[!^l]@^13" & stencil
        .Find.MatchWildcards = True
        .Find.Wrap = wdFindStop
        
        'из 1-го выделенного абзаца вычленяем вопрос (strQ) и ответ на него: абзац, содержащий "+"'
        Do While .Find.Execute
            nQ = nQ + 1
            strQ = nQ & ") " & Mid(.Range.Paragraphs(1), InStr(.Range.Paragraphs(1), Chr(11)) + 1)
            
            If InStr(.Text, "+") = 0 Then
                strA = " Ответ на этот вопрос плюсом не отмечен либо ответов больше чем " & Qvariants & "."
            Else
                        For k = 2 To 1 + Qvariants
                        If InStr(.Range.Paragraphs.Item(k), "+") Then nA = k: Exit For
                        Next
                strA = .Range.Paragraphs.Item(nA).Range
            End If
            juice = juice + strQ + strA + Chr(13) 'к результату добавили очередную порцию данных и абзац'
        Loop
        
        .EndKey wdStory 'кусор в конец - и там печатаем результат'
        .TypeText juice
        With .Find: .Text = vbNullChar: .MatchWildcards = False: End With   'очистка окна поиска'
    End With
    
End Sub

Запуск: Alt-S. «Разобранную» таблицу можно вернуть по Ctrl-Z дважды.

Число вариантов ответа можно варьировать. А для 4, конечно, легче вручную повырезать, чем изучать английский, справку и затем ещё 2 часа кандыбаться с кодом.