Sub PreserveMailMergeFormFieldsNewDoc()

Dim fFieldText() As String
Dim iCount As Integer
Dim fField As FormField
Dim sWindowMain, sWindowMerge As String

On Error GoTo ErrHandler

' Store Main merge document window name.
sWindowMain = ActiveWindow.Caption

' Because the document contains form fields,
' it should be protected, so unprotect document.
If ActiveDocument.ProtectionType <> wdNoProtection Then
   ActiveDocument.Unprotect
End If

' Loop through all text form fields
' in the main mail merge document.
For Each aField In ActiveDocument.FormFields

   ' If the form field is a text form field...
   If aField.Type = wdFieldFormTextInput Then

      ' Redim array to hold contents of text field.
      ReDim Preserve fFieldText(2, iCount + 1)

      ' Place content and name of field into array.
      fFieldText(0, iCount) = aField.Result
      fFieldText(1, iCount) = aField.Name
      fFieldText(2, iCount) = aField.TextInput.Default

      ' Select the form field.
      aField.Select

      ' Replace it with placeholder text.
      Selection.TypeText "<" & fFieldText(1, iCount) & "PlaceHolder>"

      ' Increment icount
      iCount = iCount + 1

   End If

Next aField

' Perform mail merge to new document.
ActiveDocument.MailMerge.Destination = wdSendToNewDocument
ActiveDocument.MailMerge.Execute

' Find and Replace placeholders with form fields.
doFindReplace iCount, fField, fFieldText()

' Protect the merged document.
ActiveDocument.Protect Password:="xxxx", NoReset:=True, _
   Type:=wdAllowOnlyFormFields

' Set zoom to 100 on merged document
ActiveWindow.ActivePane.View.Zoom.Percentage = 100

' Get name of final merged document.
sWindowMerge = ActiveWindow.Caption

' Reactivate the main merge document.
Windows(sWindowMain).Activate

' Find and replace placeholders with form fields.
doFindReplace iCount, fField, fFieldText()

' Switch back to the merged document.
Windows(sWindowMerge).Activate

ErrHandler:

End Sub

Sub doFindReplace(iCount As Integer, fField As FormField, fFieldText() As String)

' Go to top of document.
Selection.HomeKey Unit:=wdStory

' Initialize Find.
Selection.Find.ClearFormatting

With Selection.Find
   .Forward = True
   .Wrap = wdFindContinue
   .Format = False
   .MatchCase = False
   .MatchWholeWord = False
   .MatchWildcards = False
   .MatchSoundsLike = False
   .MatchAllWordForms = False

   ' Loop form fields count.
    For i = 0 To iCount

      ' Execute the find.
      Do While .Execute(FindText:="<" & fFieldText(1, i) _
         & "PlaceHolder>") = True

         ' Replace the placeholder with the form field.
         Set fField = Selection.FormFields.Add _
            (Range:=Selection.Range, Type:=wdFieldFormTextInput)

         ' Restore form field contents and bookmark name.
         fField.Result = fFieldText(0, i)
         fField.Name = fFieldText(1, i)
         fField.TextInput.Default = fFieldText(2, i)
      Loop

      ' Go to top of document for next find.
      Selection.HomeKey Unit:=wdStory

   Next
End With

End Sub