Save generated Word file with unique name (mailmerge)

Question

I need help with my macro. I need to save the generated Word file via mail merge.

Sub RunMerge()

Dim wd As Object
Dim wdocSource As Object

Dim strWorkbookName As String

On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
    Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0

Set wdocSource = wd.Documents.Open("C:\Users\admin\Desktop\New folder (2)\G706014 ver.7.0.docx")

strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name

wdocSource.Mailmerge.MainDocumentType = wdFormLetters

wdocSource.Mailmerge.OpenDataSource _
        Name:=strWorkbookName, _
        AddToRecentFiles:=False, _
        Revert:=False, _
        Format:=wdOpenFormatAuto, _
        Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
        SQLStatement:="SELECT * FROM `Mailing$`"

With wdocSource.Mailmerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = wdDefaultLastRecord
    End With
    .Execute Pause:=False
End With

wd.Visible = True
wdocSource.Close SaveChanges:=False

Set wdocSource = Nothing
Set wd = Nothing

End Sub

This macro just generate the file but doesn't save it.

Can somebody update it?

But the name of the save file has to be value of Excel file, worksheet mailing, cell A2

Destination for saving is: C:\Users\admin\Desktop\New folder (2)\docs

Answer 1

Added this in your code :

Dim PathToSave As String
PathToSave = "C:\Users\admin\Desktop\New folder (2)\docs\" & Sheets("mailing").Range("A2").Value2 & ".docx"
'PathToSave = "C:\Users\admin\Desktop\New folder (2)\docs\Merge_Mail_" & Replace(Replace(Now(), "/", "-"), ":", ".") & ".docx"
If Dir(PathToSave, 0) <> vbNullString Then
    wd.FileDialog(FileDialogType:=msoFileDialogSaveAs).Show
Else
    wd.activedocument.SaveAs2 PathToSave, wdFormatDocumentDefault
End If

Here is the full code :

Sub RunMerge()

Dim wd As Object, _
    wdocSource As Object, _
    PathToSave As String

Dim strWorkbookName As String

On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
    Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0

Set wdocSource = wd.Documents.Open("C:\Users\admin\Desktop\New folder (2)\G706014 ver.7.0.docx")

strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name

wdocSource.MailMerge.MainDocumentType = wdFormLetters

wdocSource.MailMerge.OpenDataSource _
        Name:=strWorkbookName, _
        AddToRecentFiles:=False, _
        Revert:=False, _
        Format:=wdOpenFormatAuto, _
        Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
        SQLStatement:="SELECT * FROM `Mailing$`"

With wdocSource.MailMerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = wdDefaultLastRecord
    End With
    .Execute Pause:=False
End With

PathToSave = "C:\Users\admin\Desktop\New folder (2)\docs\" & Sheets("mailing").Range("A2").Value2 & ".docx"
'PathToSave = "C:\Users\admin\Desktop\New folder (2)\docs\Merge_Mail_" & Replace(Replace(Now(), "/", "-"), ":", ".") & ".docx"
If Dir(PathToSave, 0) <> vbNullString Then
    wd.FileDialog(FileDialogType:=msoFileDialogSaveAs).Show
Else
    wd.activedocument.SaveAs2 PathToSave, wdFormatDocumentDefault
End If

wd.Visible = True
wdocSource.Close SaveChanges:=False

Set wdocSource = Nothing
Set wd = Nothing

End Sub