rahul36
08-09-2016, 10:28 PM
Hi, I am new to this forum :) The excel macro below is supposed to open a word document and automatically mail merge from the spreadsheet, but the macro is returning automation error unless the concerned Word document is already open. Is this due to any problems with rights and privileges. I am already logged in as administrator.
Can some one provide any suggestions or advice on how to alter this code to prevent the errors. Thank you :)
Error screens are attached as attachments
16833
16832
The program:
Const wdFormLetters = 0, wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0, wdDefaultFirstRecord = 1, wdDefaultLastRecord = -16
Sub RunMerge()
Dim wd As Object, wdocSource As Object
Dim sh As Worksheet
Dim Lrow As Long, i As Long
Dim cdir As String, client As String, newname As String, newdirname As String
Dim sSQL As String
cdir = "C:\Users\Kamlesh\Desktop\"
Set wd = CreateObject("Word.Application")
Set wdocSource = wd.Documents.Open(cdir & "\master\Regen-booking.docx")
Set sh = ActiveSheet
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
With sh
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To Lrow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
client = .Cells(i, 1).Value
newname = "Regen Booking Form - " & client & ".docx"
'If Dir(cdir & "\" & client, vbDirectory) = "" Then
'MkDir cdir + client
'End If
'newdirname = cdir & "\" & client
wdocSource.MailMerge.MainDocumentType = wdFormLetters
'~~> Sample String
sSQL = "SELECT * FROM `Sheet1$` WHERE [Client Name] = '" & .Range("A" & i).Value & "'"
wdocSource.MailMerge.OpenDataSource Name:=strWorkbookName, _
AddToRecentFiles:=False, Revert:=False, Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:=sSQL
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
wd.ActiveDocument.SaveAs cdir & newname
wd.ActiveDocument.Close SaveChanges:=False
End If
Next i
End With
wdocSource.Close SaveChanges:=False
'wd.Quit
Set wdocSource = Nothing
Set wd = Nothing
End Sub
Can some one provide any suggestions or advice on how to alter this code to prevent the errors. Thank you :)
Error screens are attached as attachments
16833
16832
The program:
Const wdFormLetters = 0, wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0, wdDefaultFirstRecord = 1, wdDefaultLastRecord = -16
Sub RunMerge()
Dim wd As Object, wdocSource As Object
Dim sh As Worksheet
Dim Lrow As Long, i As Long
Dim cdir As String, client As String, newname As String, newdirname As String
Dim sSQL As String
cdir = "C:\Users\Kamlesh\Desktop\"
Set wd = CreateObject("Word.Application")
Set wdocSource = wd.Documents.Open(cdir & "\master\Regen-booking.docx")
Set sh = ActiveSheet
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
With sh
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To Lrow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
client = .Cells(i, 1).Value
newname = "Regen Booking Form - " & client & ".docx"
'If Dir(cdir & "\" & client, vbDirectory) = "" Then
'MkDir cdir + client
'End If
'newdirname = cdir & "\" & client
wdocSource.MailMerge.MainDocumentType = wdFormLetters
'~~> Sample String
sSQL = "SELECT * FROM `Sheet1$` WHERE [Client Name] = '" & .Range("A" & i).Value & "'"
wdocSource.MailMerge.OpenDataSource Name:=strWorkbookName, _
AddToRecentFiles:=False, Revert:=False, Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:=sSQL
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
wd.ActiveDocument.SaveAs cdir & newname
wd.ActiveDocument.Close SaveChanges:=False
End If
Next i
End With
wdocSource.Close SaveChanges:=False
'wd.Quit
Set wdocSource = Nothing
Set wd = Nothing
End Sub