Question

我真的很期待得到帮助，因为我已经尝试了很长时间了...

我想在excel中获得一个按钮，以启动单词mailmerge并将每个字母保存为单个文档。我已经找到了一个代码，这样做很好。

现在出现了问题：我需要excel根据A列中的数字采用不同的单词模板（A列称为Anz）。因此，如果列A = 0，将不会有任何邮件合并（我已经通过在SQL语句中添加“ where（Anz> 0）来进行管理。

如果列A = 1，则excel必须将sb1.docx作为正确的邮件合并模板。如果列A = 2，则应为sb2.docx，依此类推。数字从0到6。

我不知道该怎么做：（

到目前为止，我的代码（可以运行，但仅适用于sb1.docx）。

Sub RunMerge()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*/\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "sb1.docx"
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
  With .MailMerge
    .MainDocumentType = wdFormLetters
    .OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
      LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
      "Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
      SQLStatement:="SELECT * FROM `Sheet1$` where (Anz>0)"
    For i = 1 To .DataSource.RecordCount
      .Destination = wdSendToNewDocument
      .SuppressBlankLines = True
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
        If Trim(.DataFields("ID")) = "" Then Exit For
        StrName = .DataFields("ID")
      End With
      .Execute Pause:=False
      For j = 1 To Len(StrNoChr)
        StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
      Next
      StrName = Trim(StrName)
      With wdApp.ActiveDocument
        .SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
        ' and/or:
        '.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
        .Close SaveChanges:=False
      End With
    Next i
    .MainDocumentType = wdNotAMergeDocument
  End With
  .Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub

Answer 1

尝试一下。

要求：
-每个Anz号都有对应的模板
-Excel电子表格中有一个名为“ Anz”的列
-您必须将Microsoft Word对象库添加到VBA IDE引用

实施：
1）复制代码并将其粘贴到vba模块中
2）定制代码（寻求>>>>定制此<<<<）

更新：
1）调整了queryString
2）更新了OpenDataSource代码，使其更加清晰
3）添加了一个fileCounter

代码：

' First you have to configure the settings in each template so the word template filters the data already
' Also add a reference in Excel / VBA IDE to: Microsoft Word [Version] Object Library
Public Sub RunMergeDifferentWordTemplates()

    ' Declare objects
    Dim wordApp As Word.Application
    Dim wordTemplate As Word.Document
    Dim wordMergedDoc As Word.MailMerge

    ' Declare other variables
    Dim sourceBookPath As String
    Dim sheetSourceName As String
    Dim excelColumnFilter As String
    Dim queryString As String
    Dim baseQueryString As String

    Dim wordTemplateDirectory As String
    Dim wordTemplateFileName As String
    Dim wordTemplateFullPath As String
    Dim wordOutputDirectory As String
    Dim wordOutputFileName As String
    Dim wordOutputFullPath As String

    Dim idListValues As Variant ' Array
    Dim idValue As Integer
    Dim idCounter As Integer
    Dim recordCounter As Integer
    Dim fileCounter As Integer

    ' >>>>> Customize this <<<<<<

    ' This would be better to hold it in an Excel structured table
    ' I'm not including 0 as it's not needed (these would correspon to the anz values).
    idListValues = Array(1, 2, 3, 4, 5, 6)

    ' Excel source settings:
    sourceBookPath = ThisWorkbook.FullName
    sheetSourceName = "Sheet1" ' The sheet where the data of the mail merge is located
    excelColumnFilter = "Anz" ' The column we use to filter the mail merge data
    baseQueryString = "SELECT * FROM `" & sheetSourceName & "$` where `" & excelColumnFilter & "` = [columFilterValue] order by `" & excelColumnFilter & "` ASC" ' Would be a better practice to use an Excel structured table: https://support.office.com/en-us/article/overview-of-excel-tables-7ab0bb7d-3a9e-4b56-a3c9-6c94334e492c

    ' Word settings:
    wordTemplateDirectory = ThisWorkbook.Path & "\" ' Include slash at the end
    wordTemplateFileName = "sb[columFilterValue].docx" ' Include in the string [columFilterValue] where you want it to be replaced (remember that you have one template for each number)
    wordOutputDirectory = ThisWorkbook.Path & "\" ' Include slash at the end
    wordOutputFileName = "MailMergeDifferent[columFilterValue]_[Record]" ' Leave the [columFilterValue] and [Record] tags inside the path to identify each document. We'll replace it ahead, dynamically

    ' Initialize word object
    Set wordApp = New Word.Application
    wordApp.Visible = True
    wordApp.DisplayAlerts = wdAlertsNone

    ' Loop through each idValue in idListValues
    For idCounter = 0 To UBound(idListValues)

        ' Process each word template
        idValue = idListValues(idCounter)
        queryString = Replace(baseQueryString, "[columFilterValue]", idValue)
        wordTemplateFullPath = wordTemplateDirectory & Replace(wordTemplateFileName, "[columFilterValue]", idValue)

        Set wordTemplate = wordApp.Documents.Open(wordTemplateFullPath)

        Set wordMergedDoc = wordTemplate.MailMerge

        ' Process the template's mail merge
        With wordMergedDoc

            .MainDocumentType = wdFormLetters

            .OpenDataSource _
                Name:=sourceBookPath, _
                ReadOnly:=True, _
                Format:=wdOpenFormatAuto, _
                Revert:=False, _
                AddToRecentFiles:=False, _
                LinkToSource:=False, _
                Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
                    "Data Source=" & sourceBookPath & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
                SQLStatement:=queryString

            .Destination = wdSendToNewDocument

            .SuppressBlankLines = True

            ' Each anz have matching records inside the excel worksheet (generate a word file for each one)
            For recordCounter = 1 To .DataSource.RecordCount

                ' Select each record
                With .DataSource

                    .FirstRecord = wordMergedDoc.DataSource.ActiveRecord
                    .LastRecord = wordMergedDoc.DataSource.ActiveRecord

                End With
                .Execute Pause:=False

                ' Add the columnFilterValue and the record identifier to the word file name
                ' Replace the columnFilterValue and the Record tags
                wordOutputFullPath = wordOutputDirectory & Replace(Replace(wordOutputFileName, "[columFilterValue]", idValue), "[Record]", recordCounter)

                ' Save and close the resulting document
                wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputFullPath, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
                wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputFullPath, FileFormat:=wdFormatPDF, AddToRecentFiles:=False
                wordApp.ActiveDocument.Close SaveChanges:=False

                .DataSource.ActiveRecord = wdNextRecord

                ' Count files generated
                fileCounter = fileCounter + 1


            Next recordCounter

        End With


        ' Close word template without saving
        wordTemplate.Close False

    Next idCounter

    ' Clean up word objects
    wordApp.Visible = False
    Set wordApp = Nothing

    ' Alert process finished
    MsgBox fileCounter & " files generated"

End Sub

Excel VBA邮件与条件合并

1 个答案: