InsertCrossReference from Bookmarks

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...

Code:

---

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

---

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:

Code:

---

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.