Поиск и копирование в новый документ

[viperm]

Здравствуйте

Я новичок в VBS.

есть текст : "Получив этот дар, обезъяны бросили все свои новые интеллектуальные возможности на решение двух задач: найти замену своей косматой шкуре, которая была бы сменной, красиво раскрашенной и выгодно подчеркивала бы их сильные места, а также избавить РУС 2726 себя от того, чтобы прикладывать
отличие от всех остальных живых существ мира, живущих «здесь и сейчас», оказались плен РУС 2724 никами более длинного, практически бесконечного промежутка времени, который они стали называть «жизнью», различая в ней «прошлое» и «будущее». Таким образом, их сила оказалась размазанной по бесконечности, а интенсивность переживания текущего момента снизилась
большой машиной — это была 940 модель «Вольво». Теперь он выглядел необычайно солидным и уверенным в себе. Даже его голос изменился. И вот, однажды РУС В 2726, когда мы, стоя в огромной пробке, медленно продвигались вперед, Рони, наморщив лоб, сказал мне:
— Слушай, а тебе не кажется, что в этой машине я выгляжу маленьким?
Игнасио Рамирес, «Назад к звездам»"

Из него мне нужно по поиску ключевого слова "РУС" вытащит в новый документ "РУС+(соседнее слово/шифр)".
Должно получиться:
РУС 2726
РУС 2724


Нашел и немного откорректировал данный код:

Option Explicit

Sub Макрос()
Dim aDoc As Document
Dim nDoc As Document
Application.ScreenUpdating = False
Set aDoc = ActiveDocument
Set nDoc = Documents.Add
aDoc.Activate
With Selection
    .HomeKey Unit:=wdStory
    .Find.ClearFormatting
    With .Find
        .Text = "РУС"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
End With
Do
    With Selection
            If Not .Find.Execute Then Exit Do
                .Copy
            End With
    nDoc.Activate
    Selection.EndKey Unit:=wdStory
    Selection.Paste
    Selection.InsertBreak 6
    aDoc.Activate
Loop
nDoc.Activate
Application.ScreenUpdating = True
End Sub

Слово находит и вставляет но без последующего.


При данном коде, попадаю в бесконечный цикл:

Option Explicit

Sub Макрос()
Dim aDoc As Document
Dim nDoc As Document
Application.ScreenUpdating = False
Set aDoc = ActiveDocument
Set nDoc = Documents.Add
aDoc.Activate
With Selection
    .HomeKey Unit:=wdStory
    .Find.ClearFormatting
    With .Find
        .Text = "РУС"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
End With
Do
    With Selection
            If Not .Find.Execute Then Exit Do
           .MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend         
           .Copy
           End With
    nDoc.Activate
    Selection.EndKey Unit:=wdStory
    Selection.Paste
    Selection.InsertBreak 6
    aDoc.Activate
Loop
nDoc.Activate
Application.ScreenUpdating = True
End Sub

Не могу найти свою ошибку. За ранее спасибо за подсказку. По возможности, может кто знает как сохранять данные в exel а не в word.

[Борис_Р]

Вам помогут подстановочные знаки, см.:
http://artefact.lib.ru/design/text_khozyainov.shtml
В первом макросе замените строку
.Text = "РУС"
на строку
.Text = "РУС [0-9]{1;}"

а также строку
.MatchWildcards = False
на строку
.MatchWildcards = True 'включить подстановочные знаки

[viperm]

Спасибо. Буду разбираться.

[viperm]

За 1 ответ спасибо все работает, круто!

А может кто нибудь подсказать чтобы все сохранилось в exel, а не word?