Макрос копирования абзацев и строк таблицы

[EducatedFool]

Приветствую, коллеги.

К сожалению, в объектной модели Word я разбираюсь намного хуже, чем в Excel, потому вынужден обратиться к вам за помощью.

Передо мной стоит задача сделать макрос, который будет искать в документе Word закладки с заданным именем, и копировать строку, содержащую закладку, нужное количество раз.


Пример исходного документа: скриншот

Пример того, что надо получить: скриншот

Пример того, что сейчас получается: скриншот


Использую такой макрос: (файл с макросом - во вложении)

Sub test()
    ' создаём копию документа, чтобы на нем экспериментировать
    Dim doc As Document: Set doc = Documents.Add
    ThisDocument.Range.Copy
    doc.Range.PasteSpecial
    
    ' теперь надо из закладок "multirow*" создать копии строк,
    ' в количестве RowsCount& штук
    RowsCount& = 4

    Dim bm As Bookmark, ra As Range
    For Each bm In doc.Bookmarks
        If bm.Name Like "multirow*" Then    ' у нас в документе - 3 таких закладки
            
            bm.Range.Copy ' иногда криво копируется, надо расширить диапазон до целой строки
            ' (может быть выделен абзац целиком, может - его часть (или несколько ячеек таблицы)
            ' А копировать надо абзац (или строку таблицы) ЦЕЛИКОМ
            
            bm.Range.Select
            For i = 1 To RowsCount&
                Selection.MoveDown Unit:=4, Count:=1, Extend:=0    ' wdMove=0
                Selection.PasteAndFormat 16    ' wdFormatOriginalFormatting=16
                Selection.MoveUp Unit:=4, Count:=1, Extend:=0

                With Selection
                    .Expand (4)    ' wdParagraph=4
                    .Find.Execute "#}", , , False, , , , , , "#" & i & "}", 2 ' это работает
                    
                    ' почему-то не работает замена текста {%index%} на номер строки
                    ' хотя 4-й параметр FALSE должен отключать использование подстановочных знаков
                    .Find.Execute "{%index%}", , , False, , , , , , i, 2
                End With
            Next
            bm.Range.Delete
        End If
    Next
End Sub

Т.е. надо каждую закладку скопировать ниже 4 раза,
а потом удалить исходную строку (в которой была закладка)

Причем все это безобразие должно работать в любой версии Word (2003-2013)
PS: Макрос будет запускаться из Excel, потому константы числами заменены.

Для чего я всё это делаю: хочу добиться вот такого результата, только ещё и с шаблонами Word.


Что подправить в коде?

PS: не умею писать код для Word без использования Select
Без него можно обойтись в данном случае? Или использование Select только в случае с Excel все тормозит?

[viter.alex]

Игорь, попробуй такой вариант:

Sub test()
    ' создаём копию документа, чтобы на нем экспериментировать
    Dim doc As Document: Set doc = Documents.Add
    ThisDocument.Range.Copy
    doc.Range.PasteAndFormat 16

    ' теперь надо из закладок "multirow*" создать копии строк,
    ' в количестве RowsCount& штук
    RowsCount& = 4

    Dim bm As Bookmark, ra As Range
    For Each bm In doc.Bookmarks
        If bm.Name Like "multirow*" Then    ' у нас в документе - 3 таких закладки
            If bm.Range.Information(12) Then 'Закладка в таблице
                Dim oFirstCellRange As Range
                For i = 1 To RowsCount
                    With bm.Range
                        Set oFirstCellRange = .Cells(1).Range
                        oFirstCellRange.Collapse 1 'wdCollapseStart
                        .Copy
                        'Вставка строки из закладки над закладкой
                        oFirstCellRange.PasteAndFormat 16 'wdFormatOriginalFormatting
                        .Tables(1).Rows(.Rows(1).Index).Cells(1).Range.Text = i
'                        Replacements .Tables(1).Rows(.Rows(1).Index).Range, "{%index%}", i
                    End With
                Next
                bm.Range.Rows(1).Delete
            Else
                Dim bmText As String
                bmText = bm.Range.Text
                For i = RowsCount To 1 Step -1
                    With bm.Range
                        .InsertParagraphAfter
                        With .Paragraphs.First.Next
                            .Range.InsertCrossReference ReferenceType:=2, ReferenceKind:=-1, _
                        ReferenceItem:=bm.Name, InsertAsHyperlink:=False, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
                            .Range.Fields.Unlink
                        End With

                        Replacements .Paragraphs.First.Next.Range, "#}", "#" & i & "}"
                    End With
                Next
                bm.Range.Delete
            End If
        End If
    Next
End Sub

Sub Replacements(rng As Range, ByVal FindText As String, ByVal ReplaceText As String)
    rng.Find.Execute FindText:=FindText, ReplaceWith:=ReplaceText, Replace:=2
End Sub

В твоём варианте {%index%} не заменялся, потому что после проведения замены Selection меняется и нужно выделять заново.

[EducatedFool]

Александр, огромное спасибо!

Как всегда, все в лучшем виде.
Сам бы я такое ни за что не написал)