Copy, Paste, and Format Multiple Headings

[Dretherix]

This is my first time trying to create a macro in Word and I'm stuck. I'm trying to automate a tedious process where I used multiple Heading 1 (title), Heading 2 (author) and Heading 3's (date) to create a table of contents. I've tried using the building ToC tool, but it doesn't allow for the customization that I need. Basically, what I need to do is take the first H2, copy and paste it at the top of the page, italicize it, put a colon after it, copy and paste H1 after the colon, hyperlink that back to where it's located in the body of the doc, then add a space and put H3 in parentheses so that it always follows the (Month Day, Year) format. And then do it again for the next set.

Here is what the first one should look like:

Author: Title (February 12, 2016)
(The Title should be hyperlinked, but I can't add links since it's my first post)

And here is what that is pulling from:

Title (H1)
Author (H2)
12 Feb 2016 (H3)

I've cobbled together bits and pieces from this and other forums and pasted what I have below. However, it pastes both H1 and H2 twice, and I'm not even close to figuring out how to put them on the same line, italicize and hyperlink. I wish I had a better attempt to include, but I'm struggling. Any help would be greatly appreciated.

Here is what I have so far:


Sub HeadingTest4()
'
' HeadingTest4 Macro
'
'
While Selection.Characters.Last.Next.Style = "Heading 1"
Selection.MoveEnd Unit:=wdCharacter, Count:=1
Wend
Selection.MoveStart Unit:=wdCharacter, Count:=1
Selection.Collapse Direction:=wdCollapseEnd
With Selection.Find
.ClearFormatting
.Text = ""
.MatchWildcards = False
.Forward = True
.Style = ActiveDocument.Styles("Heading 1")
.Execute
.ClearFormatting
End With
Selection.Find.Execute
Selection.Copy
Selection.MoveUp Unit:=wdWindow, Count:=1
Selection.PasteAndFormat (wdListDontMerge)
Selection.PasteAndFormat (wdFormatPlainText)
While Selection.Characters.Last.Next.Style = "Heading 2"
Selection.MoveEnd Unit:=wdCharacter, Count:=1
Wend
Selection.MoveStart Unit:=wdCharacter, Count:=1
Selection.Collapse Direction:=wdCollapseEnd
With Selection.Find
.ClearFormatting
.Text = ""
.MatchWildcards = False
.Forward = True
.Style = ActiveDocument.Styles("Heading 2")
.Execute
.ClearFormatting
End With
Selection.Find.Execute
Selection.Copy
Selection.MoveUp Unit:=wdWindow, Count:=1
Selection.PasteAndFormat (wdListDontMerge)
Selection.PasteAndFormat (wdFormatPlainText)
End Sub

[gmayor]

You need to embrace ranges in order to do this or you will get hopelessly tangled in knots as you appear to have discovered. If I understand yoyur requirement correctly and PROVIDED THE THREE PARAGRAPHS ARE CONSECUTIVE as shown, the following should work. Ensure that the bookmark name used is not used in the document already as bookmarks cannot be duplicated. If you do use BM1, BM2 etc then change BM here to something else that you haven't used.:

Option Explicit

Sub AddPsuedoTOC()
Dim oHead1 As Range
Dim oHead2 As Range
Dim oHead3 As Range
Dim oLink As Range
Dim oRng As Range
Dim strText As String
Dim strLink As String
Dim i As Long, j As Long
Dim iMargin As Long
Const strBM As String = "BM" 'a bookmark name not used in the document
i = 0
strText = ""
iMargin = ActiveDocument.Sections(1).PageSetup.PageWidth - _
ActiveDocument.Sections(1).PageSetup.RightMargin - _
ActiveDocument.Sections(1).PageSetup.LeftMargin
Set oRng = ActiveDocument.Range
With oRng.Find
.Style = "Heading 1"
Do While .Execute
Set oHead1 = oRng.Paragraphs(1).Range
Set oHead2 = oRng.Paragraphs(1).Range.Next.Paragraphs(1).Range
Set oHead3 = oHead2.Paragraphs(1).Range.Next.Paragraphs(1).Range
oHead1.End = oHead1.End - 1
oHead2.End = oHead2.End - 1
oHead3.End = oHead3.End - 1
i = i + 1
ActiveDocument.Bookmarks.Add strBM & i, oHead1
strText = strText & Trim(oHead2.Text) & Chr(58) & Chr(32) & _
Trim(oHead1.Text) & Chr(32) & Chr(40) & Trim(oHead3.Text) & _
Chr(41) & vbTab & "Page " & oHead1.Information(wdActiveEndPageNumber) & vbCr
oRng.Collapse 0
Loop
End With
ActiveDocument.Range.InsertParagraphBefore
Set oRng = ActiveDocument.Paragraphs(1).Range
oRng.Text = strText

For j = 1 To i
Set oRng = ActiveDocument.Paragraphs(j).Range
oRng.Style = "Normal"
oRng.ParagraphFormat.TabStops.ClearAll
oRng.ParagraphFormat.TabStops.Add _
Position:=iMargin, _
Alignment:=wdAlignTabRight, _
Leader:=wdTabLeaderDots
Set oLink = ActiveDocument.Paragraphs(j).Range
oRng.Collapse 1
oRng.MoveEndUntil Chr(58)
oRng.Italic = True
oLink.MoveStartUntil Chr(58)
oLink.Start = oLink.Start + 1
oLink.MoveEndUntil Chr(40), wdBackward
oLink.End = oLink.End - 1
ActiveDocument.Hyperlinks.Add oLink, "", strBM & j
Next j
lbl_Exit:
Set oRng = Nothing
Set oHead1 = Nothing
Set oHead2 = Nothing
Set oHead3 = Nothing
Set oLink = Nothing
Exit Sub
End Sub

[gmaxey]

Graham,

Very, very well done :clap:

In the event your assumption is wrong and the paragraphs are not consecutive, then a minor change should resolve:



Sub AddPsuedoTOC()
Dim oHead1 As Range, oHead2 As Range, oHead3 As Range
Dim oLink As Range, oRng As Range
Dim strText As String, strLink As String
Dim i As Long, j As Long, iMargin As Long
Const strBM As String = "BM" 'a bookmark name not used in the document
i = 0
strText = ""
iMargin = ActiveDocument.Sections(1).PageSetup.PageWidth - _
ActiveDocument.Sections(1).PageSetup.RightMargin - _
ActiveDocument.Sections(1).PageSetup.LeftMargin
Set oRng = ActiveDocument.Range
With oRng.Find
.Style = "Heading 1"
Do While .Execute
Set oHead1 = oRng.Paragraphs(1).Range
Set oHead2 = oHead1
Do
Set oHead2 = oHead2.Paragraphs(1).Range.Next.Paragraphs(1).Range
Loop Until oHead2.Style = "Heading 2"
Set oHead3 = oHead2
Do
Set oHead3 = oHead3.Paragraphs(1).Range.Next.Paragraphs(1).Range
Loop Until oHead3.Style = "Heading 3"
oHead1.End = oHead1.End - 1
oHead2.End = oHead2.End - 1
oHead3.End = oHead3.End - 1
i = i + 1
ActiveDocument.Bookmarks.Add strBM & i, oHead1
strText = strText & Trim(oHead2.Text) & Chr(58) & Chr(32) & _
Trim(oHead1.Text) & Chr(32) & Chr(40) & Trim(oHead3.Text) & _
Chr(41) & vbTab & "Page " & oHead1.Information(wdActiveEndPageNumber) & vbCr
oRng.Collapse 0
Loop
End With
ActiveDocument.Range.InsertParagraphBefore
Set oRng = ActiveDocument.Paragraphs(1).Range
oRng.Text = strText
For j = 1 To i
Set oRng = ActiveDocument.Paragraphs(j).Range
oRng.Style = "Normal"
oRng.ParagraphFormat.TabStops.ClearAll
oRng.ParagraphFormat.TabStops.Add _
Position:=iMargin, _
Alignment:=wdAlignTabRight, _
Leader:=wdTabLeaderDots
Set oLink = ActiveDocument.Paragraphs(j).Range
oRng.Collapse 1
oRng.MoveEndUntil Chr(58)
oRng.Italic = True
oLink.MoveStartUntil Chr(58)
oLink.Start = oLink.Start + 1
oLink.MoveEndUntil Chr(40), wdBackward
oLink.End = oLink.End - 1
ActiveDocument.Hyperlinks.Add oLink, "", strBM & j
Next j
lbl_Exit:
Set oRng = Nothing
Set oHead1 = Nothing
Set oHead2 = Nothing
Set oHead3 = Nothing
Set oLink = Nothing
Exit Sub
End Sub

[Dretherix]

This is amazing! I really appreciate the help. It will save me an incredible amount of time.

I do have a couple quick questions.
1. If I delete "& "Page " & oHead1.Information(wdActiveEndPageNumber)" will that get rid of the periods and page number that follow heading? I can't have it show the page number or have all of those dots (strict formatting rules).
Edited after I realized that I could just test this...I was close. I deleted "& vbTab & "Page " & oHead1.Information(wdActiveEndPageNumber) and that seems to work
2. Is there way to make it so that it pulls the date and reformats it into Month Day, Year. For example, since different publications use different dates styles, like 16 February 2016, 2/16/16, Feb. 16, 2016, etc. I need the date to always read February 16, 2016. What I used to do was pull all of the dates into an excel spreadsheet an have it run the following formula: "TEXT(D2, "([$-409]mmmm d, yyyy)"). Not sure if there's something similar that can be done in Word.

Thanks again for the help. It is immensely appreciated.

[gmaxey]

Sub AddPsuedoTOC()
Dim oHead1 As Range, oHead2 As Range, oHead3 As Range
Dim oLink As Range, oRng As Range
Dim strText As String, strLink As String
Dim i As Long, j As Long, iMargin As Long
Const strBM As String = "BM" 'a bookmark name not used in the document
i = 0
strText = ""
iMargin = ActiveDocument.Sections(1).PageSetup.PageWidth - _
ActiveDocument.Sections(1).PageSetup.RightMargin - _
ActiveDocument.Sections(1).PageSetup.LeftMargin
Set oRng = ActiveDocument.Range
With oRng.Find
.Style = "Heading 1"
Do While .Execute
Set oHead1 = oRng.Paragraphs(1).Range
Set oHead2 = oHead1
Do
Set oHead2 = oHead2.Paragraphs(1).Range.Next.Paragraphs(1).Range
Loop Until oHead2.Style = "Heading 2"
Set oHead3 = oHead2
Do
Set oHead3 = oHead3.Paragraphs(1).Range.Next.Paragraphs(1).Range
Loop Until oHead3.Style = "Heading 3"
oHead1.End = oHead1.End - 1
oHead2.End = oHead2.End - 1
oHead3.End = oHead3.End - 1
i = i + 1
ActiveDocument.Bookmarks.Add strBM & i, oHead1
strText = strText & Trim(oHead2.Text) & Chr(58) & Chr(32) & _
Trim(oHead1.Text) & Chr(32) & Chr(40) & _
Trim(Format(oHead3.Text, "MMMM d, yyyy")) & Chr(41) & vbCr 'Modified
oRng.Collapse 0
Loop
End With
ActiveDocument.Range.InsertParagraphBefore
Set oRng = ActiveDocument.Paragraphs(1).Range
oRng.Text = strText
For j = 1 To i
Set oRng = ActiveDocument.Paragraphs(j).Range
oRng.Style = "Normal"
oRng.ParagraphFormat.TabStops.ClearAll
oRng.ParagraphFormat.TabStops.Add _
Position:=iMargin, _
Alignment:=wdAlignTabRight, _
Leader:=wdTabLeaderDots
Set oLink = ActiveDocument.Paragraphs(j).Range
oRng.Collapse 1
oRng.MoveEndUntil Chr(58)
oRng.Italic = True
oLink.MoveStartUntil Chr(58)
oLink.Start = oLink.Start + 2 'Link only text not leading space/
oLink.MoveEndUntil Chr(40), wdBackward
oLink.End = oLink.End - 2 'Link only text not trailing space.
oLink.Select
ActiveDocument.Hyperlinks.Add oLink, "", strBM & j
Next j
lbl_Exit:
Set oRng = Nothing
Set oHead1 = Nothing
Set oHead2 = Nothing
Set oHead3 = Nothing
Set oLink = Nothing
Exit Sub
End Sub

[Dretherix]

Greg, you are my hero. If you're ever in NY, let me know and I'll buy you a beer. And thank you to Graham as well for the initial, and extensive, first draft. Offer stands for you too.

[gmaxey]

I was just Johnny Come Late. I figured Graham, and where he is, was OOC for the rest of the day. The credit is really his.

[Dretherix]

Hi,

So I need to make some changes to the macro and I am stuck again on one part. I've figured out how to get rid of Heading 3 and the date, but I need to switch the order of Heading 1 and Heading 2 in the end result. E.g., I need to make Heading 1 come before the colon and Heading 2 come after and be hyperlinked. I've tried switching some of the numbers around, but it just breaks the macro. Here is what I have so far:


Sub AddPsuedoTOC() Dim oHead1 As Range, oHead2 As Range, oHead3 As Range
Dim oLink As Range, oRng As Range
Dim strText As String, strLink As String
Dim i As Long, j As Long, iMargin As Long
Const strBM As String = "BM" 'a bookmark name not used in the document
i = 0
strText = ""
iMargin = ActiveDocument.Sections(1).PageSetup.PageWidth - _
ActiveDocument.Sections(1).PageSetup.RightMargin - _
ActiveDocument.Sections(1).PageSetup.LeftMargin
Set oRng = ActiveDocument.Range
With oRng.Find
.Style = "Heading 1"
Do While .Execute
Set oHead1 = oRng.Paragraphs(1).Range
Set oHead2 = oHead1
Do
Set oHead2 = oHead2.Paragraphs(1).Range.Next.Paragraphs(1).Range
Loop Until oHead2.Style = "Heading 2"
oHead1.End = oHead1.End - 1
oHead2.End = oHead2.End - 1
i = i + 1
ActiveDocument.Bookmarks.Add strBM & i, oHead1
strText = strText & Trim(oHead2.Text) & Chr(58) & Chr(32) & _
Trim(oHead1.Text) & Chr(32) & vbCr 'Modified
oRng.Collapse 0
Loop
End With
ActiveDocument.Range.InsertParagraphBefore
Set oRng = ActiveDocument.Paragraphs(1).Range
oRng.Text = strText
For j = 1 To i
Set oRng = ActiveDocument.Paragraphs(j).Range
oRng.Style = "Normal"
oRng.ParagraphFormat.TabStops.ClearAll
oRng.ParagraphFormat.TabStops.Add _
Position:=iMargin, _
Alignment:=wdAlignTabRight, _
Leader:=wdTabLeaderDots
Set oLink = ActiveDocument.Paragraphs(j).Range
oRng.Collapse 1
oRng.MoveEndUntil Chr(58)
oRng.Italic = True
oLink.MoveStartUntil Chr(58)
oLink.Start = oLink.Start + 2 'Link only text not leading space/
oLink.MoveEndUntil Chr(40), wdBackward
oLink.End = oLink.End - 2 'Link only text not trailing space.
oLink.Select
ActiveDocument.Hyperlinks.Add oLink, "", strBM & j
Next j
lbl_Exit:
Set oRng = Nothing
Set oHead1 = Nothing
Set oHead2 = Nothing
Set oHead3 = Nothing
Set oLink = Nothing
Exit Sub
End Sub