Copy content under 6 specific headings, paste it over 6 placeholder text items

[Walentyn]

The goal: for about six specifically named H1 Headings, I want to copy all the content under each heading, and paste it over specific placeholder text elsewhere in the same document.
For example, I want to copy the contents under the heading "CONTENTS", and paste it over the placeholder text "<Contents>" in the same document, and delete the original. Then move onto the next heading "ABOUT THE AUTHOR", and paste its content over the placeholder text "<About the Author>".
The reason: I have a macro that transforms a finished etext document into the makings of a braille-ready document (to be opened by Duxbury braille translation software). That macro adds a series of fixed headings and placeholder text content to the finished etext, in the order required of braille documents. Rather than manually move/consolidate the original file's headings with the braille ready version, I'd like a macro that does most/all of the work.
Progress so far: I have used Greg Maxey's macro on another thread which copies the right content, and added a bit of Find and Replace code to give a better idea of where I'm going, with notes about where I need code to run through a series of headings, rather than just the one:


Sub TextBetweenHeading1()
'A basic Word macro coded by Greg Maxey
'with modifications to copy content under named headings and replace specific placeholder text with it

Dim docCurrent As Document
Dim oRng As Range
Dim oRngReplace As Range
Set docCurrent = ActiveDocument
Set oRng = docCurrent.Range

Selection.Collapse wdCollapseEnd

' HERE I WOULD LIKE TO FIND A SERIES OF DEFINED HEADINGS, eg _
DEDICATION, CONTENTS, COVER INFORMATION, BY THE SAME AUTHOR, ABOUT THE AUTHOR, TRANSCRIBER'S NOTE etc
With Selection.Find
.Style = ThisDocument.Styles("Heading 1")
.Text = "CONTENTS^13"
.Wrap = wdFindContinue
If .Execute = False Then
MsgBox "Heading not found."
' Move to next item if heading not found, which occasionally it may not be
End If
End With

Selection.Collapse wdCollapseEnd
Set oRng = Selection.Range

oRng.Collapse wdCollapseEnd
Do While oRng.Paragraphs(1).Style = "Heading 1"

oRng.Move wdParagraph, 1
Loop
Do
oRng.MoveEnd wdParagraph, 1
oRng.Select
Loop Until oRng.Paragraphs.Last.Range.Style = "Heading 1" Or oRng.Paragraphs.Last.Range.End = ActiveDocument.Range.End
If Not oRng.End = ActiveDocument.Range.End Then oRng.MoveEnd wdParagraph, -1
Do
oRng.MoveStart wdParagraph, -1
oRng.Select
Loop Until oRng.Paragraphs(1).Range.Style = "Heading 1" Or oRng.Paragraphs(1).Range.Start = ActiveDocument.Range.Start
If Not oRng.Start = ActiveDocument.Range.Start Or oRng.Paragraphs(1).Style = "Heading 1" Then oRng.MoveStart wdParagraph, 1
oRng.Select
oRng.Copy

' HERE WOULD BE A CORRESPONDING A SERIES OF PLACEHOLDER TEXT ITEMS THAT oRng WOULD REPLACE: _
"<Cover Information>","<About this Book>","<By the Same Author>","<About the Author>","<Dedication>","<Transcriber's Note>", etc

Set oRngReplace = docCurrent.Range
With oRngReplace.Find
.ClearFormatting
.Text = "<Contents>"
.Wrap = wdFindStop
While .Execute
oRngReplace.Text = oRng.Text
Wend
End With

' Delete the text at original location, tho' could also now add the original H1 heading as well
oRng.Delete


lbl_Exit:
Exit Sub
End Sub

[macropod]

If, instead of relying on the placeholder text, you assigned each content control a title of the same name, you could use code like:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Style = wdStyleHeading1
.Format = True
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
If Not ActiveDocument.SelectContentControlsByTitle(Split(.Text, vbCr)(0))(1) Is Nothing Then
Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
ActiveDocument.SelectContentControlsByTitle(Split(.Text, vbCr)(0))(1).Range.FormattedText = Rng.FormattedText
Rng.Text = vbNullString
End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub

[Walentyn]

Perhaps I have confused things by the phrase "placeholder text". I'm not referring to the placeholder text of a control (there are no content controls in my files), just a bit of dummy text to remind the user where to put the copied/deleted contents. It's not even in a paragraph of its own, since the files in question use text formulas like [[*<*]] and [[*p*]] which will be converted to line breaks and paragraph markers respectively when the file is opened in Duxbury Braille Translator. (It's what the original conversion macro does: headings remain as paragraphs, and all other contents are agglomerated into single paragraphs beneath them). So I'm not sure how I could use content controls.

[macropod]

In that case, try:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String, RngSrc As Range, RngTgt As Range
StrFnd = "DEDICATION|CONTENTS|COVER INFORMATION|BY THE SAME AUTHOR|ABOUT THE AUTHOR|TRANSCRIBER'S NOTE"
For i = 0 To UBound(Split(StrFnd, "|"))
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = Split(StrFnd, "|")(i)
.Replacement.Text = ""
.Style = wdStyleHeading1
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If .Find.Found = True Then
Set RngSrc = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
.Collapse wdCollapseEnd
Set RngTgt = RngSrc.Duplicate
RngTgt.End = ActiveDocument.Range.End
With RngTgt
With .Find
.Text = "<" & Split(StrFnd, "|")(i) & ">"
.Execute
End With
If .Find.Found = True Then .FormattedText = RngSrc.FormattedText
RngSrc.Text = vbNullString
End With
End If
End With
Next
Application.ScreenUpdating = True
End Sub

[Walentyn]

That looks more along the lines that I had imagined, ie a kind of array variable.

So far, the code yields a deletion of each H1 heading and its content. But it leaves the target string untouched.

In case I haven't been explicit enough, here's the goal using a schematic example of a file's content:

CONTENTS (heading level 1)
Textual content of CONTENTS, formatted (= everything in file till next heading 1 = RngSrc)

CONTENTXS (heading level 1)
[[*fr*]]Page[[*<*]][[*rm5*]][[*p*]]<CONTENTS>[[*<*]][[*pg*]]etc (= new location showing where RngSrc should be plonked, ie replacing RngTgt = <CONTENTS> )

The result would be:

CONTENTXS
[[*fr*]]Page[[*<*]][[*rm5*]][[*p*]]Textual content of CONTENTS, formatted[[*<*]][[*pg*]]etc

... and spelling of headings would be tidied up later.

[macropod]

CONTENTXS (heading level 1)
[[*fr*]]Page[[*<*]][[*rm5*]][[*p*]]<CONTENTS>[[*<*]][[*pg*]]etc (= new location showing where RngSrc should be plonked, ie replacing RngTgt = <CONTENTS> )

The result would be:

CONTENTXS
[[*fr*]]Page[[*<*]][[*rm5*]][[*p*]]Textual content of CONTENTS, formatted[[*<*]][[*pg*]]etc.

Which is exactly what the code does. The <CONTENTS> string is replaced by all of the content associated with the corresponding Heading 1 range. Everything else is left alone.

[Walentyn]

Hi Paul,
After further testing, I got the code to work by adding the .Wrap line to find the target <dummy text>:


With RngTgt
With .Find
.Wrap = wdFindContinue
.Text = "<" & Split(StrFnd, "|")(i) & ">"
.Execute
End With
If .Find.Found = True Then .Text = RngSrc.Text
RngSrc.Text = vbNullString
End With


Ideally the RngSrc would also drop the Heading 1 heading itself. Is it easy to alter the source range by knocking off the first paragraph heading?

Cheers
Chris

[macropod]

I got the code to work by adding the .Wrap line to find the target <dummy text>:
That suggests your array items are not in the same order as the items appear in the document.

Ideally the RngSrc would also drop the Heading 1 heading itself. Is it easy to alter the source range by knocking off the first paragraph heading?
After:
Set RngSrc = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
insert:
RngSrc.Paragraphs.First.Range.Text = vbNullString

[Walentyn]

This is a stunning result. The whole procedure now works exactly as intended. It was the last piece of the puzzle in a bigger procedure, so thank you very much indeed for that.

Thanks also for the explanation about the order of array items. Good to know better how that should work. As for modifying range objects, well, you make it look so simple! I suppose it is when you know how.

Thanks again.