Excel VBA条件邮件合并：按Anz列值选择对应Word模板求助

Got it, let's fix your code so it uses the correct Word template (sb1.docx to sb6.docx) based on the Anz value in your Excel sheet. Here's how to adjust it, with key changes explained:

Key Changes Made: #

• Moved the template opening logic inside the record loop so each row can use its own matching template
• Dynamically fetch the Anz value from the current mail merge record to build the template filename
• Added validation to skip records with invalid Anz values (1-6) or blank IDs to avoid errors
• Cleaned up template handling to ensure each template is closed after processing its record
• Fixed a small typo in your original code where Application.ScreenUpdating was incorrectly set to False at the end

Modified Code #

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, AnzValue As Integer
    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 & "\"
    
    ' Create a temporary blank doc to access the Excel data source
    Set wdDoc = wdApp.Documents.Add
    With wdDoc.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)"
        
        ' Loop through each valid record
        For i = 1 To .DataSource.RecordCount
            .DataSource.ActiveRecord = i
            AnzValue = .DataSource.DataFields("Anz").Value
            StrName = .DataSource.DataFields("ID").Value
            
            ' Skip invalid records
            If Trim(StrName) = "" Or AnzValue < 1 Or AnzValue > 6 Then GoTo NextRecord
            
            ' Build the template path using the Anz value
            StrMMDoc = StrMMPath & "sb" & AnzValue & ".docx"
            
            ' Open the specific template for this record
            Dim tempTemplate As Word.Document
            Set tempTemplate = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
            
            With tempTemplate.MailMerge
                .MainDocumentType = wdFormLetters
                ' Filter data source to only the current record (using ID)
                .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 (ID='" & StrName & "')"
                
                ' Generate the single letter document
                .Destination = wdSendToNewDocument
                .SuppressBlankLines = True
                .Execute Pause:=False
                
                ' Clean up invalid characters in the filename
                For j = 1 To Len(StrNoChr)
                    StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
                Next
                StrName = Trim(StrName)
                
                ' Save the generated document (uncomment PDF line if needed)
                With wdApp.ActiveDocument
                    .SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
                    '.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
                    .Close SaveChanges:=False
                End With
                
                .MainDocumentType = wdNotAMergeDocument
            End With
            
            ' Close the template without saving changes
            tempTemplate.Close SaveChanges:=False
            Set tempTemplate = Nothing
            
NextRecord:
        Next i
        .MainDocumentType = wdNotAMergeDocument
    End With
    
    ' Clean up the temporary document and Word app
    wdDoc.Close SaveChanges:=False
    wdApp.DisplayAlerts = wdAlertsAll
    wdApp.Quit
    
    Set wdDoc = Nothing: Set wdApp = Nothing
    Application.ScreenUpdating = True
End Sub

How It Works: #

1. We start with a temporary Word document to connect to your Excel data source and loop through only valid records (where Anz>0).
2. For each record, we pull the Anz value to build the correct template filename (e.g., sb3.docx for Anz=3).
3. We open the matching template, filter the mail merge to only the current record (using the ID field), generate the letter, save it, then close the template.
4. Validation checks ensure we skip any records that might cause errors (blank IDs or Anz values outside 1-6).

Notes: #

• Ensure all your templates (sb1.docx to sb6.docx) are stored in the same folder as your Excel workbook.
• If you need to expand the Anz range later, just adjust the validation check (AnzValue <1 Or AnzValue>6) to match your new range.

内容的提问来源于stack exchange，提问作者Marie