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