The reason that the bookmarks are lost is because each bookmark in a
document must define a unique location in the document.  If you execute the
merge to a new document, there would, in your case, be 7 locations, each
trying to use the one bookmark, which of course cannot be the case, so the
bookmarks do not appear in the document.

The following macro can be used as a work around

' Throwaway Macro created by Doug Robbins to "preserve" bookmarks during a
MailMerge

'

Dim abm As Bookmark, bmrange As Range, i As Long, Result As Document, j As
Long, k As Long, linkrange As Range, linktarget As String

Dim Source As Document

Set Source = ActiveDocument

i = 1

For j = 1 To Source.MailMerge.DataSource.RecordCount

   For Each abm In ActiveDocument.Range.Bookmarks

       System.PrivateProfileString("c:\bookmarks.txt", "bookmarkNames",
"bookmark" & i) = abm.Name & Format(j)

       i = i + 1

   Next

Next j

For Each abm In ActiveDocument.Range.Bookmarks

   abm.Range.InsertBefore "#"

   abm.Range.InsertAfter "#"

Next

With ActiveDocument.MailMerge

   .Destination = wdSendToNewDocument

   .Execute

End With

Set Result = ActiveDocument

k = 1

Selection.HomeKey wdStory

Selection.Find.ClearFormatting

With Selection.Find

   Do While .Execute(FindText:="#*#", MatchWildcards:=True,
Wrap:=wdFindContinue, Forward:=True) = True

       Set bmrange = Selection.Range

       bmrange.Characters(bmrange.Characters.Count).Delete

       bmrange.Characters(1).Delete

       Result.Bookmarks.Add System.PrivateProfileString("c:\bookmarks.txt",
"bookmarkNames", "bookmark" & k), bmrange

       k = k + 1

   Loop

End With

For i = 1 To Result.Hyperlinks.Count

   linktarget = Result.Hyperlinks(i).SubAddress

   Set linkrange = Result.Hyperlinks(i).Range

   linkrange.Select

   linktarget = linktarget &
Format(Selection.Information(wdActiveEndSectionNumber))

   Result.Hyperlinks.Add Result.Hyperlinks(i).Range, "", linktarget

Next i

Source.Activate

Selection.HomeKey wdStory

Selection.Find.ClearFormatting

With Selection.Find

   Do While .Execute(FindText:="#*#", MatchWildcards:=True,
Wrap:=wdFindContinue, Forward:=True) = True

       Set bmrange = Selection.Range

       bmrange.Characters(bmrange.Characters.Count).Delete

       bmrange.Characters(1).Delete

   Loop

End With