Word - Поиск и выделение всей строки с найденным словом

[Kost Troll]

Т.е. Задача стоит такая :
Документ - имеется много строк вот такого скажем вида

папа мама сын дочь тесть зять12
мама папа дочь сын деверь золовка 14
сын дочь мама папа 15
мама папа дочь сын сноха отчим 14

Поиск ведем по конечной цифре в строке - 14

Т.е. - надо найти все строчки с цифрой 14, выделить всю строку, где найдена такая цифра, чтобы скопировать.

Причем слова перед цифрами стоят разной длины.

Я пробовал в поиске Word вбивать такую комбинацию
^? символ любого знака + цифра 14
т.е. вот такой вид :
^?14

Можно подставить еще несколько знаков, т.е.
^?^?^?^?^?^?^?^?14

Но слова в строке все разной длины и так не получается

В общем - прошу совета !

[Sasha_Smirnov]

Выделять нужно, отметив (в окне, что по Ctrl-F) подстановочные знаки.

И туда скопируйте такой текст:
<*[0-9][^11^13]

Вопрос — а дальше-то что с выделением делать?

[Sasha_Smirnov]

Ну на всякий случай сделал для каких угодно абзацев (строк, обрывающихся символом с кодом 11 [перевод строки — как у вас] либо 13 [между абзацами, а также в конце файла]) — кроме пустых (на них Exit).

Sub AnySeg()

Dim act As Long                 ' счётчик
Selection.HomeKey wdStory       ' курсор в начало

    With Selection.Find
        .MatchWildcards = True  ' флажок Подстановочные знаки (не забыть потом снять)
    Do
        .Text = "*[^11^13]"             'то, что ищем в тексте документа Word'
        .Replacement.Text = "^&"        'заменяем то, что ищем, на то же самое (здесь)'
        .Wrap = wdFindStop              'останавливаемся на найденной комбинации'
        .Format = False                 'формат не учитываем'
        .Execute Replace:=wdReplaceOne  'заменяем 1 раз (что нашли)'
        
        If Asc(Selection) = 13 Then MsgBox act: Exit Do
        Selection.Collapse wdCollapseEnd 'сброс выделения к его концу (иначе - зациклится)
        
        act = act + 1 'считаем акт «замены»
    Loop Until Not .Found
    
    End With

End Sub

[Kost Troll]

Сорри у меня чегой-то ваш скрипт зависает
Вот этот скрипт работает :

Sub Выделение()
'
' Выделение Макрос
'
'

Dim Выделение As String
Dim b As Integer
Выделение = InputBox("Введите слово для выделения строки", "Выделяем строки")
If Выделение = Empty Then Exit Sub
b = ActiveDocument.BuiltInDocumentPrope rties(wdPropertyLines)
Application.ScreenUpdating = False
For i = 0 To b
With Selection.Find
.Text = Выделение
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Not Selection.Font.Bold Then
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.MoveRight Unit:=wdCharacter, Count:=1
Else
MsgBox "Выделение закончено!"
Exit Sub
End If
Next i
End Sub

Но он выделяет найденные строки со словом - ЖИРНЫМ.

А мне надо не жирным а выделение строки для копирования в другой документ.
Или скажем так - скопировать все выделенное жирным в другой документ
Я в программировании - дуб.
Так что простите если сморозил какую глупость

[Казанский]

Попробуйте - будет сформирован новый документ, содержащий искомые строки:

Sub Макрос2()
Dim aDoc As Document, 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 = "14"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
End With
Do
    With Selection
        If Not .Find.Execute Then Exit Do
        .HomeKey Unit:=wdLine
        .EndKey Unit:=wdLine, Extend:=wdExtend
        .Copy
        .EndKey Unit:=wdLine
    End With
    nDoc.Activate
    Selection.EndKey Unit:=wdStory
    Selection.Paste
    aDoc.Activate
Loop
nDoc.Activate
Application.ScreenUpdating = True
End Sub

[Sasha_Smirnov]

        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

можно убрать за ненадобностью.

.Text = "14" я бы, для большего охвата, заменил на .Text = "^#^#" (две цифры)

[378]

А ещё можно в бесплатном редакторе Notepad++ в поиске набрать 14 и все строки выведутся, выделяем их, копируем и всё.