InsertCrossReference from Bookmarks

[leonvl]

Looking for a snippet that can generate Cross-References from all Bookmarked Items within a document.
Let's say I have a comprehensive document that contains 20 bookmarked words - then I would like the macro for each of them find the exact word within the document and create a cross reference to the bookmarked item. I thought this would be of much use to many of us, but can't find anything and have no clue where to start.

Any help welcome...


Sub CrossRefBookmark()Selection.InsertCrossReference ReferenceType:=wdRefTypeBookmark, _
ReferenceKind:=wdContentText, ReferenceItem:=Trim(Selection.Text), _
InsertAsHyperlink:=True
End Sub

[macropod]

The following macro generates a table of all bookmarks at the end of either the active document or a new document, plus another table of all references to those bookmarks, each table including details of the story range names, page & line numbers and contents:

Sub ListBkMrksAndRefs()
Application.ScreenUpdating = False
Dim oBkMrk As Bookmark, StrBkMk As String, StrXREf As String, StrStory As String
Dim wdDocIn As Document, wdDocOut As Document, Rng As Range, Fld As Field, bHid As Boolean, Dest
Dest = MsgBox(Prompt:="Output to New Document? (Y/N)", Buttons:=vbYesNoCancel, Title:="Destination Selection")
If Dest = vbCancel Then Exit Sub
Set wdDocIn = ActiveDocument
If Dest = vbYes Then Set wdDocOut = Documents.Add
If Dest = vbNo Then Set wdDocOut = wdDocIn
With wdDocIn
bHid = .Bookmarks.ShowHidden
.Bookmarks.ShowHidden = True
If .Bookmarks.Count > 0 Then
StrBkMk = vbCr & "Bookmark" & vbTab & "Page" & vbTab & "Line" & vbTab & "Story" & Chr(160) & "Range" & vbTab & "Contents"
StrXREf = vbCr & "Bookmark Ref" & vbTab & "Page" & vbTab & "Line" & vbTab & "Story" & Chr(160) & "Range" & vbTab & "Type" & vbTab & "Text"
For Each oBkMrk In .Bookmarks
Select Case oBkMrk.StoryType
Case 1: StrStory = "Main text"
Case 2: StrStory = "Footnotes"
Case 3: StrStory = "Endnotes"
Case 4: StrStory = "Comments"
Case 5: StrStory = "Text frame"
Case 6: StrStory = "Even pages header"
Case 7: StrStory = "Primary header"
Case 8: StrStory = "Even pages footer"
Case 9: StrStory = "Primary footer"
Case 10: StrStory = "First page header"
Case 11: StrStory = "First page footer"
Case 12: StrStory = "Footnote separator"
Case 13: StrStory = "Footnote continuation separator"
Case 14: StrStory = "Footnote continuation notice"
Case 15: StrStory = "Endnote separator"
Case 16: StrStory = "Endnote continuation separator"
Case 17: StrStory = "Endnote continuation notice"
Case Else: StrStory = "Unknown"
End Select
StrBkMk = StrBkMk & vbCr & oBkMrk.Name & vbTab & _
oBkMrk.Range.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & _
oBkMrk.Range.Information(wdFirstCharacterLineNumber) & vbTab & StrStory & vbTab & oBkMrk.Range.Text
Next oBkMrk
For Each Rng In .StoryRanges
Select Case Rng.StoryType
Case 1: StrStory = "Main text"
Case 2: StrStory = "Footnotes"
Case 3: StrStory = "Endnotes"
Case 4: StrStory = "Comments"
Case 5: StrStory = "Text frame"
Case 6: StrStory = "Even pages header"
Case 7: StrStory = "Primary header"
Case 8: StrStory = "Even pages footer"
Case 9: StrStory = "Primary footer"
Case 10: StrStory = "First page header"
Case 11: StrStory = "First page footer"
Case 12: StrStory = "Footnote separator"
Case 13: StrStory = "Footnote continuation separator"
Case 14: StrStory = "Footnote continuation notice"
Case 15: StrStory = "Endnote separator"
Case 16: StrStory = "Endnote continuation separator"
Case 17: StrStory = "Endnote continuation notice"
Case Else: StrStory = "Unknown"
End Select
For Each Fld In Rng.Fields
With Fld
If (.Type = wdFieldRef) Then
StrXREf = StrXREf & vbCr & Split(Trim(.Code.Text), " ")(1) & vbTab & _
.Result.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & _
.Result.Information(wdFirstCharacterLineNumber) & vbTab & StrStory & vbTab & "Ref"
ElseIf (.Type = wdFieldPageRef) Then
StrXREf = StrXREf & vbCr & Split(Trim(.Code.Text), " ")(1) & vbTab & _
.Result.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & _
.Result.Information(wdFirstCharacterLineNumber) & vbTab & StrStory & vbTab & "PageRef"
End If
StrXREf = StrXREf & vbTab & .Result
End With
Next
Next
Else
MsgBox "There are no bookmarks in this document", vbExclamation
GoTo Done
End If
End With
With wdDocOut
Set Rng = .Range.Characters.Last
With Rng
.Text = StrBkMk
.Start = .Start + 1
.ConvertToTable Separator:=vbTab
With .Tables(1)
.AutoFitBehavior wdAutoFitContent
.Columns.Borders.Enable = True
.Rows.Borders.Enable = True
.Rows.First.Range.Font.Bold = True
End With
End With
Set Rng = .Range.Characters.Last
With Rng
.Text = StrXREf
.Start = .Start + 1
.ConvertToTable Separator:=vbTab
With .Tables(1)
.AutoFitBehavior wdAutoFitContent
.Columns.Borders.Enable = True
.Rows.Borders.Enable = True
.Rows.First.Range.Font.Bold = True
End With
End With
.Bookmarks.ShowHidden = bHid
End With
Done:
Set Rng = Nothing: Set wdDocIn = Nothing: Set wdDocOut = Nothing
Application.ScreenUpdating = True
End Sub
Note that line numbers only apply to the main story. Other stories will return -1.