Move text using headings - vba

Question

I am trying to 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 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 Section (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 explored / read quite a few posts on the selection.find, selection.move and range.move methods.
I reached a stage where I 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
I struggle 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").

Answer 1

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