Move text using headings-CodePudding

First time I write a question on stackoverflow, after more than 5 years using it ! Hopefully I did not miss the answer in another post and that I'll meet the standards expected to ask a question:

I am trying to dynamically move text in a MS-word document based on a user input, using Headings to find what to move and where to move it.

For the sake example let's say my document is organized like this:

Section 1 Section 2 Section 3 Annex 1

With "Section 1", "Section 2", "Section 3" and "Annex" being defined as Headings 1 style.

In each Sections (and annex) you have a mixed batch of text, tables, pictures, etc.

Let's assume users get asked the following question through VBA (triggered either via a button click event or document open event, does not matter - this I know how to do). Depending on their answer, I would like to either

a) do nothing

b) do the following actions:

select the entire "Section 1", including Heading and all the text, figures, tables, etc, in it (in other words - until "Section 2" starts)
move it between Section 3 and Annex 1 so that the document structure now looks like this: Section 2 Section 3 Section 1 Annex 1

Dim answer as Integer

answer = MsgBox("Do you like cookies?", vbQuestion   vbYesNo   vbDefaultButton2, "The big question")

if answer = vbYes Then

' e.g. do nothing or end sub

else

' move text as described above

I have of course explored / read quite a few posts on the selection.find, selection.move and range.move methods.

I have reached a stage where I manage to find and select the Section I am interested in using the following code;


Dim answer as Integer

answer = MsgBox("Do you like cookies?", vbQuestion   vbYesNo   vbDefaultButton2, "The big question")

if answer = vbYes Then

' e.g. do nothing or end sub

else

    Selection.WholeStory
    Selection.Collapse wdCollapseStart

    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 1")
    With Selection.Find
        .Text = "Section 1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = True
    End With
    Selection.Find.Execute
    Selection.Collapse wdCollapseStart

    Dim r1 As Range
    Set r1 = Selection.Range

    ' keep format settings, only change text
    Selection.Find.Text = "Section 2"
    If Selection.Find.Execute Then
        Selection.Collapse wdCollapseStart
    Else
        Selection.WholeStory
        Selection.Collapse wdCollapseEnd
    End If
    Dim r2 As Range
    Set r2 = ActiveDocument.Range(r1.Start, Selection.Start)
    r2.Select

But I struggle to reach the finish line - that to now move this range (or this selection) to another position in the document based on Headings (in this case, to insert this section between "Section 3" and "Annex 1").

Any suggestions?

CodePudding user response：

You are on the right lines but need to avoid using the Selection object. There are rare circumstances when using Selection is unavoidable but this isn't one of them.

Word has a number of hidden predefined bookmarks, one of which returns the full range of a heading level. This is used in the GetHeadingBlock function below.

A Range also has a FormattedText property that can be used instead of the clipboard.

Sub MoveSection()
    Dim moveRange As Range, destRange As Range
    Set moveRange = GetHeadingBlock("Section 1", wdStyleHeading1)
    If Not moveRange Is Nothing Then
        Set destRange = GetHeadingBlock("Section 3", wdStyleHeading1)
        If Not destRange Is Nothing Then
            destRange.Collapse wdCollapseEnd
            destRange.FormattedText = moveRange.FormattedText
            moveRange.Delete
        End If
    End If
End Sub

Public Function GetHeadingBlock(headingText As String, headingStyle As WdBuiltinStyle) As Range
   Dim findRange As Range
   Set findRange = ActiveDocument.Content
   With findRange.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = headingText
      .Style = headingStyle
      .Replacement.Text = ""
      .Forward = True
      .Format = True
      .Wrap = wdFindStop
      If .Execute Then Set GetHeadingBlock = _
         findRange.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
   End With
End Function