Excel VBA почта слияния с условиями

Question

Я действительно с нетерпением жду, чтобы получить некоторую помощь, потому что я пытаюсь так долго ...

Я хочу получить кнопку в Excel, которая запускает слово mailmerge и сохраняет каждое письмо как один документ,Я уже нашел код, который делает это нормально.

Теперь возникает проблема: мне нужно Excel, чтобы взять разные шаблоны слов в зависимости от числа в столбце A (столбец A называется Anz).Поэтому, если в столбце A = 0 не будет никакого слияния (я уже справился с этим, добавив «where (Anz> 0) к выражению sql.

Если в столбце 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) Настройте код (ищите >>>>, настройте этот <<<<) <br>

Обновления:
1) Отрегулирован queryString
2) Обновлен код OpenDataSource, чтобы он был более понятным
3) Добавлен файл Counter

Код:

' 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