Макрос vba word для помещения строки в существующий заголовок

Пытаться:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "ID:*^13"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    Rng.End = Rng.Paragraphs.First.Range.End - 1
    Rng.InsertAfter Split(Split(.Duplicate.Text, ":")(1), vbCr)(0)
    .Text = vbNullString
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

Выполните поиск по шаблону для любого маркера абзаца, за которым следует ID:.

.Text = "^13ID:"
.Replacement.Text = ""

Вам нужно будет указать стиль текста, заменяющего стиль заголовка, потому что, когда вы удаляете маркер абзаца в конце абзаца заголовка, вы также удаляете информацию о стиле для абзаца заголовка.

Вам нужно будет сделать это с каждым заголовком стиля, за которым следует текст ID:.

Обновлено 1 ноября 2018 г.

Следующий код должен работать. Я получил некоторые подсказки от оригинального кода Macropods.

Обновление 2 2018-11-01

Пересмотрено для работы со списком стилей, определенных пользователем по запросу ОП.

Sub ConsolidateHeadingWithID()

Const HEADINGS                                   As String = "Heading 1,Heading 2,Heading 3,Heading 4,Heading 5,Other style,another style"

Dim my_headings                                 As Variant
Dim my_heading                                  As Variant
my_headings = Split(HEADINGS, ",")

For Each my_heading In my_headings

        With ActiveDocument.StoryRanges(wdMainTextStory)

            With .Find

                .ClearFormatting
                .format = True
                .Text = ""
                .Style = my_heading
                .MatchWildcards = True
                .Wrap = wdFindStop
                .Execute

            End With

            Do While .Find.Found

                If .Duplicate.Next(unit:=wdWord).Text = "ID" Then

                    .Duplicate.Next(unit:=wdParagraph).Style = my_heading

                End If

                .Collapse wdCollapseEnd
                .MoveStart unit:=wdCharacter, Count:=2
                .Find.Execute

            Loop

        End With

        With ActiveDocument.Range.Find

            .ClearFormatting
            .format = True
            .Text = "(^13)(ID:)(*)(AWP_)([0-9]{1,})"
            .Style = my_heading
            .Replacement.Text = " [\4\5]"
            .MatchWildcards = True
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll

        End With

    Next

End Sub