If these merges are being run by automating Word, I've read that you may
need to issue .Activate on  the Window (and possibly set .Visible to True -
the ssequence may be significant).

Peter Jamieson

I think that I may have responded to an earlier post suggesting that this
was not the way to go, but in one of my more masochistic moments I developed
the following for someone

' 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