使用唯一名称保存生成的 Word 文件（邮件合并）

Question

我的宏需要帮助。我需要通过邮件合并保存生成的Word文件。

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

这个宏只生成文件但不保存它。

有人可以更新吗？

但保存文件的名称必须是 Excel 文件、工作表 mailing、单元格 A2

的值

保存目的地是：C:\Users\admin\Desktop\New folder (2)\docs

Answer 1

将此添加到您的代码中：

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

完整代码如下：

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

Answer 2

以下代码应允许您保存值单元格 A2 的基数

Dim FileName    As String
Dim FilePath    As String
FilePath = "C:\Users\admin\Desktop\New folder (2)\"
FileName = Sheets("mailing").Range("A2").Text & ".docx"
ThisWorkbook.SaveAs FileName:=FilePath & "\" & FileName, _
OriginalFormat:=wdOriginalDocumentFormat

使用唯一名称保存生成的 Word 文件（邮件合并）

Save generated Word file with unique name (mailmerge)

vba

excel

ms-word

mailmerge