Macro to export mail merge fields to excel

[Andrew]

I am trying to figure out a way to take a mail merge documentment and export the merge fields to an excel doc. I have many documents with many fields and need a efficient way to take the merge fields from any of those docs and export them to excel.

Also, if someone knows how to save that excel document with the same name as the word doc that exported the data that would be icing on the cake. I am able to figure out how to save the doc with a specific name "c:\blah.xls"... but cannot figure out how to make the name of the word doc a varible and then to attach a .xls.

EggHeadCafe.com - .NET Developer Portal of Choice
http://www.eggheadcafe.com

 

[Doug Robbins - Word MVP]

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



--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP