VBA Macro for Word Mail merge
I have created an Excel Macro to manipulate data in an excel spreadsheet save it then open a Word template in order to do a data merge. I do both a letter and then envelopes.
Here is my problem. Sometime it runs great all the way through. Other times I get the following:
Run-time error '464';
The remote server machine does not exist or is unavailable.
I only get that when it tries to save the second document. I have made that part of the code red.
Any help would be greatly appreciated.
Sub FormatThankyou()
Dim wsData As Worksheet
Dim appWd As Word.Application
Dim WdDoc As Word.Document
d = 2 ' Data File
GetDate:
InputDate = InputBox("Please enter the weekending date in the following format: 070305.", "Date Input")
If Len(InputDate) = 6 Then
GoTo OpenDataFiles
Else
End If
MsgBox "Date must be exactly 6 digits and you entered " & InputDate
GoTo GetDate
OpenDataFiles:
Workbooks.Open ("\\fileserve\Timetndr\Service Level\Tommy Nobis\Data Files\Thank You Letter.xls")
Set wsData = ActiveWorkbook.Worksheets("Thank You Letter")
DataEof = ActiveSheet.UsedRange.Rows.Count
FixName:
Do Until d > DataEof
If Len(Trim(wsData.Cells(d, "i"))) > 0 Then
wsData.Cells(d, "a") = wsData.Cells(d, "i")
ElseIf Len(Trim(wsData.Cells(d, "e"))) > 0 Then
wsData.Cells(d, "a") = wsData.Cells(d, "e")
wsData.Cells(d, "b") = wsData.Cells(d, "f")
Else
wsData.Cells(d, "a") = wsData.Cells(d, "c")
wsData.Cells(d, "b") = wsData.Cells(d, "d")
End If
If Len(Trim(wsData.Cells(d, "u"))) = 0 And Len(Trim(wsData.Cells(d, "v"))) = 0 Then
wsData.Cells(d, "u") = "None Given"
Else
End If
d = d + 1
Loop
Fini:
ActiveWorkbook.Save
fname = ("\\fileserve\Timetndr\Service Level\Tommy Nobis\Thank You Letter." + InputDate + ".xls")
ActiveWorkbook.SaveAs Filename:=fname
ActiveWorkbook.Close
MailMerge:
fname = ("\\fileserve\Timetndr\Service Level\Tommy Nobis\Thank You Letter." + InputDate + ".doc")
Set appWd = CreateObject("Word.Application")
appWd.Visible = True
On Error Resume Next
On Error GoTo 0
With appWd
Set WdDoc = appWd.Documents.Open("\\fileserve\Timetndr\Service Level\Tommy Nobis\Report Templates\Thank You Letter.doc")
WdDoc.Activate
WdDoc.MailMerge.OpenDataSource Name:="\\fileserve\Timetndr\Service Level\Tommy Nobis\Data Files\Thank You Letter.xls", _
ReadOnly:=True, LinkToSource:=0, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, _
Connection:="", SQLStatement:="", SQLStatement1:=""
With WdDoc.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute
End With
ActiveDocument.SaveAs fname
ActiveDocument.Close
End With
WdDoc.Close
Set WdDoc = Nothing
appWd.Quit
Set appWd = Nothing
fname = ("\\fileserve\Timetndr\Service Level\Tommy Nobis\Thank You Envelopes." + InputDate + ".doc")
Set appWd = CreateObject("Word.Application")
appWd.Visible = True
On Error Resume Next
On Error GoTo 0
With appWd
Set WdDoc = appWd.Documents.Open("\\fileserve\Timetndr\Service Level\Tommy Nobis\Report Templates\Envelopes.doc")
WdDoc.Activate
WdDoc.MailMerge.OpenDataSource Name:="\\fileserve\Timetndr\Service Level\Tommy Nobis\Data Files\Thank You Letter.xls"
With WdDoc.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute
End With
ActiveDocument.SaveAs fname <-- Blows up here
ActiveDocument.Close
End With
WdDoc.Close
appWd.Quit
Set WdDoc = Nothing
Set appWd = Nothing
End Sub
