Access VBA按支票号拆分邮件表格的技术求助

要实现按「Check Number（支票号）」为每个编号生成独立表格，核心是让记录集按支票号排序，然后遍历过程中跟踪当前支票号，变化时切换表格。以下是修改后的完整代码：

Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 8) As String
Dim aRow(1 To 8) As String
Dim aBody() As String
Dim lCnt As Long
Dim strpicpath As String
Dim appoutlook As Outlook.Application: Set appoutlook = New Outlook.Application
Dim mimEmail As Outlook.MailItem
Set mimEmail = appoutlook.CreateItem(olMailItem)

'strpicpath = "path"

'Create the header row
aHead(1) = "End Debtor Name"
aHead(2) = "Invoice"
aHead(3) = "Check Number"
aHead(4) = "Exception Type"
aHead(5) = "Amount"
aHead(6) = "Actions to Resolve"
aHead(7) = "Notes"
aHead(8) = "Client Response"

lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body>"

'修改查询，按支票号排序，确保同编号记录连续
strQry = "SELECT * From tbl_SendEmailsTemp ORDER BY [Check Number1]"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)

Dim currentCheckNo As Variant
currentCheckNo = Null

If Not (rec.BOF And rec.EOF) Then
    Do While Not rec.EOF
        '如果是新的支票号，创建新表格
        If Nz(rec("Check Number1"), "") <> Nz(currentCheckNo, "") Then
            currentCheckNo = rec("Check Number1")
            lCnt = lCnt + 1
            ReDim Preserve aBody(1 To lCnt)
            '添加新表格的表头
            aBody(lCnt) = "<table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
        End If
        
        '添加当前记录为表格行
        lCnt = lCnt + 1
        ReDim Preserve aBody(1 To lCnt)
        aRow(1) = rec("EndDebtor Name")
        aRow(2) = rec("Invoice #")
        aRow(3) = rec("Check Number1")
        aRow(4) = rec("Exception Type")
        aRow(5) = rec("Balance")
        aRow(6) = rec("Notes")
        aRow(7) = ""
        aRow(8) = ""
        aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
        
        rec.MoveNext
        
        '如果是最后一条记录，或者下一条记录的支票号不同，关闭当前表格
        If rec.EOF Or Nz(rec("Check Number1"), "") <> Nz(currentCheckNo, "") Then
            lCnt = lCnt + 1
            ReDim Preserve aBody(1 To lCnt)
            aBody(lCnt) = "</table><br><br>"
        End If
    Loop
End If

aBody(lCnt) = aBody(lCnt) & "</body></html>"

'create the email
With mimEmail
    .To = "test"
    '.To = ContactEmail & ";" & ContactEmail2 & ";" & ContactEmail3
    '.cc = creditrep & ";" & "credit "
    .Subject = Client_Name & ", Exceptions Report, " & Date - 1
    Dim att As Outlook.Attachment
    Set att = .Attachments.Add(strpicpath, 1, 0)
    .HTMLBody = "<img src=""Exceptions.png""'><br><br><br>" _
               & "<BODY style = font-size: 11pt>Please see below for the exceptions generated from " & Date - 1 & " transactions. All applicable back-up documentation is attached:</BODY><br><br>" _
               & Join(aBody, vbNewLine) & " <br><br>"
               
    .Display
End With

DoCmd.OpenQuery "qry_AppendEmailed"
DoCmd.OpenQuery "qry_AppendNotEmailed"
DoCmd.OpenQuery "qry_DeleteFromExceptions"

DoCmd.SetWarnings True

End Sub

关键改动说明 #

• 查询排序：在strQry中添加ORDER BY [Check Number1]，确保相同支票号的记录连续排列，这是分组的前提。
• 支票号跟踪：新增currentCheckNo变量，记录当前表格对应的支票号，每次遍历记录时对比判断是否需要新建表格。
• 表格切换逻辑：当遇到新支票号时，关闭当前表格（如果存在）并创建带表头的新表格；当记录遍历到当前支票号的最后一条时，关闭表格并添加换行分隔。
• HTML结构修正：调整aBody的初始值和收尾逻辑，确保所有表格的HTML标签完整闭合，避免格式错乱。

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