Here's the cake and its icing:

Dim Source As Document
Dim oXL As Excel.Application
Dim oWB As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim ExcelWasNotRunning As Boolean
Dim Filename As String
Dim MMfield As String

Set Source = ActiveDocument
If Source.MailMerge.MainDocumentType = wdNotAMergeDocument Then
   MsgBox "The active document is not a mailmerge main document"
   Exit Sub
ElseIf Source.MailMerge.Fields.Count = 0 Then
   MsgBox "There are no merge fields in the mail merge main document"
   Exit Sub
End If

Filename = Source.Name
Filename = Left(Filename, InStr(Filename, ".") - 1)

'If Excel is running, get a handle on it; otherwise start a new instance of
Excel
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")

If Err Then
  ExcelWasNotRunning = True
  Set oXL = New Excel.Application
End If

On Error GoTo Err_Handler

oXL.Visible = True
'Open the workbook
Set oWB = oXL.Workbooks.Add
Set oSheet = oXL.ActiveSheet
With oSheet
   For i = 1 To Source.MailMerge.Fields.Count
       MMfield = Source.MailMerge.Fields(i).Code
       MMfield = Mid(MMfield, InStr(MMfield, Chr(34)) + 1)
       MMfield = Left(MMfield, InStr(MMfield, Chr(34)) - 1)
       .Cells(1, i) = MMfield
       'Range(Asc(65) + i & "1").Select
   Next i
End With
oSheet.SaveAs Filename
oWB.Close
If ExcelWasNotRunning Then
 oXL.Quit
End If

'Make sure you release object references.
Set oRng = Nothing
Set oSheet = Nothing
Set oWB = Nothing
Set oXL = Nothing

'quit
Exit Sub

Err_Handler:
  MsgBox WorkbookToWorkOn & " caused a problem. " & Err.Description,
vbCritical, _
          "Error: " & Err.Number
  If ExcelWasNotRunning Then
      oXL.Quit
  End If