Dim bkmarkname As String
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 5")
With Selection.Find
    Do While .Execute(FindText:="", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True
        With Selection
            If Instr(.Range.Text, "|") > 0 then
                 bkmarkname = Mid(.Range.Text, InStr(.Range.Text, "|") + 2, InStrRev(.Range.Text, "|") - InStr(.Range.Text, "|") - 2)
                 ActiveDocument.Bookmarks.Add Trim(bkmarkname), .Range
            End If
            .Collapse wdCollapseEnd
        End With
    Loop
End With