导出邮件合并为基于Excel命名的Docx

Sub 导出邮件合并为基于Excel命名的Docx()
    Dim docMain As Document, docSingle As Document
    Dim i As Long, n As Long
    Dim strPath As String, strFileName As String
    Dim fldr As FileDialog, excelApp As Object, excelWorkbook As Object
    Dim excelFilePath As String, department As String, name As String

    ' 选择保存文件的文件夹
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "选择保存导出文件的文件夹"
        If .Show <> -1 Then Exit Sub '如果用户取消，则退出子程序
        strPath = .SelectedItems(1) '获取选定的路径
    End With

    ' 确保路径以反斜杠结尾
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

    ' 选择Excel文件
    Set fldr = Application.FileDialog(msoFileDialogFilePicker)
    With fldr
        .Title = "选择Excel文件"
        .Filters.Add "Excel文件", "*.xlsx; *.xls"
        If .Show <> -1 Then Exit Sub '如果用户取消，则退出子程序
        excelFilePath = .SelectedItems(1) '获取选定的Excel文件路径
    End With

    ' 打开Excel文件
    Set excelApp = CreateObject("Excel.Application")
    Set excelWorkbook = excelApp.Workbooks.Open(excelFilePath)
    excelApp.Visible = False '不显示Excel界面

    ' 设置为当前激活的文档
    Set docMain = ActiveDocument

    ' 计算合并记录的数量
    With docMain.MailMerge
        .DataSource.ActiveRecord = wdLastRecord
        n = .DataSource.ActiveRecord
        .DataSource.ActiveRecord = wdFirstRecord
        ' 遍历每个合并记录
        For i = 1 To n
            .Destination = wdSendToNewDocument
            .DataSource.FirstRecord = i
            .DataSource.LastRecord = i
            .Execute False

            ' 从Excel中读取对应的部门和姓名
            department = excelApp.Cells(i + 1, 3).Value ' 部门在第三列
            name = excelApp.Cells(i + 1, 4).Value ' 姓名在第四列

            ' 设置新文档
            Set docSingle = ActiveDocument

            ' 生成文件名
            strFileName = strPath & CleanFileName(department & "_" & name & ".docx")

            ' 保存新文档
            docSingle.SaveAs2 FileName:=strFileName, FileFormat:=wdFormatXMLDocument

            ' 关闭新文档
            docSingle.Close False
        Next i
    End With

    ' 清理并关闭Excel
    excelWorkbook.Close False
    excelApp.Quit
    Set excelWorkbook = Nothing
    Set excelApp = Nothing
  
    MsgBox n & "个文件已导出到 " & strPath, vbInformation
End Sub

' 清理文件名中的不合法字符
Function CleanFileName(ByVal FileName As String) As String
    Dim IllegalChars As Variant
    IllegalChars = Array("/", "\", ":", "*", "?", """", "<", ">", "|")
    For Each Char In IllegalChars
        FileName = Replace(FileName, Char, "")
    Next
    CleanFileName = FileName
End Function