使用所有相关行的单元格值创建一封电子邮件作为邮件 body

Question

我有一个包含 1000 多行的 Excel 文件。 A列有数据，M列有收件人1邮件，N列有收件人2邮件，O列有验证。

验证列机制：如果单元格中的值<0，则应将该行纳入电子邮件。

我需要一个宏来起草一封电子邮件，电子邮件的内容应该合并 table 列 O（键）中具有负值的所有行。
电子邮件地址应通过 Bcc 发送至 M 列中的电子邮件地址，Cc 发送至 N 列中的电子邮件地址。
邮件的主题和内容不是那么重要，但我想调整一下。出于练习的目的，它可以是“通用标题”、“通用内容”。

电子邮件草拟后，我需要在 Outlook 中单击“发送”。
发送一行电子邮件后，该行 O 列中的值应更改为具有“OK”值的绿色单元格。

宏之前的虚拟数据运行

邮件

宏后的虚拟数据运行

下面的代码为每一行创建了一封单独的电子邮件，而不是一封电子邮件，其中包含来自 A 列的单元格值组合成一个 table（或其他形式）作为电子邮件 body。我如何 re-arrange 它才能创建一封电子邮件？

Sub Send_mails()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell as Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
    For Each cell in Worksheets("test1"). Columns("O").Cells
        Set OutMail = OutApp.CreateItem(0)
        If cell.Value < 0 Then
            With OutMail
                .Bcc = Cells(cell.Row, "M").Value
                .Cc = Cells(cell.Row, "N").Value
                .Subject = "Gneric Subject"
                .Body = "Generic body text, Values from column A for each row meeting the condition, to be put here"
                .display
            End With
            Cells(cell.Row, "O").Value = "OK"
            Set OutMail = Nothing
        End If
    Next Cell
End Sub

Answer 1

如果您尝试发送一封电子邮件，抄送给 N 列中的所有收件人，密送给 M 列中的所有收件人，请使用如下逻辑：

Sub Send_mails()

Dim OutApp As Object
Dim OutMail As Object
Dim Recipient as Object
Dim ws as Worksheet
Dim cell as Range

Set ws = ThisWorkbook.Worksheets("test1")   ' Assuming ThisWorkbook is correct
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

For Each cell in ws.Columns("O").Cells     ' Better to limit this to the used range so you don't loop over 1 million rows.
    If cell.Value < 0 Then
        With OutMail
             Set Recipient = .Recipients.Add(ws.Cells(cell.Row, "M").Value
             Recipient.Type = olBcc
             Set Recipient = .Recipients.Add(ws.Cells(cell.Row, "N").Value
             Recipient.Type = olCc

             ' If you're sending the same message to everyone the next 2 lines can be moved outside of the loop
             .Subject = "Gneric Subject"
             .Body = "Generic body text, Values from column A for each row meeting the condition, to be put here"
        End With
        ws.Cells(cell.Row, "O").Value = "OK"
    End If
Next Cell
OutMail.display
Set OutMail = Nothing
Set Recipient = Nothing
Set OutApp as Nothing
Set ws = Nothing
End Sub

我没有运行这个，所以可能有错误。

Answer 2

我不确定我是否理解您的需求！根据你的虚拟数据，我 创建了一个 table 并将其命名为 tbClient。这是代码和邮件输出！您需要设置对 Microsoft Word 的引用，或者更改代码以使用后期绑定。

Option Explicit

Public ws As Worksheet
Public ol As ListObject
Public olRng As Range

Sub copyTabletoEmail()
    Dim olCol As Integer
     
    Application.ScreenUpdating = False
   
    Set ws = Sheets("Test1")
    Set ol = ws.ListObjects("tbClient")
   
    ' remove table filter buttons
    If Not ol.ShowAutoFilterDropDown Then ol.ShowAutoFilterDropDown = True
   
    ' clear table filters
    If ol.AutoFilter.FilterMode Then ol.AutoFilter.ShowAllData
   
    ' get validation column
    olCol = ol.ListColumns("Validation").Index
       
    ' filter table
    ol.Range.AutoFilter field:=olCol, Criteria1:="<0", Operator:=xlOr
   
    ' remove table filter buttons
    ol.ShowAutoFilterDropDown = False
   
    ' select table to copy
    Set olRng = ol.Range
   
    ' create mail
    Call CreateMail
    
   ' Change values on 'Validation' column
    ol.ListColumns(olCol).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = "OK"
    
    ' clear table filters
    If ol.AutoFilter.FilterMode Then ol.AutoFilter.ShowAllData
   
    Application.ScreenUpdating = True
End Sub
   
Sub CreateMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim OutInsp As Object
    Dim mailTo As String, mailCC As String
   
    Dim olCol As Integer
    Dim rCell As Range
    Dim addRng As Range
   
    On Error GoTo errHandler
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    ' display mail
    OutMail.display
   
    ' If you're sending the same message to everyone the next 2 lines can be moved outside of the loop
    OutMail.Subject = "Generic Subject"
   
    ' Range of mail addresses
    olCol = ol.ListColumns("Client mail").Index
    Set addRng = ol.ListColumns(olCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
   
    ' get the mail addresses
    For Each rCell In addRng
        With OutMail
             mailTo = mailTo & rCell.Value & ";"
             mailCC = mailCC & rCell.Offset(0, 1).Value & ";"
        End With
    Next rCell
   
    OutMail.to = mailTo
    OutMail.cc = mailCC
   
    ' Declare word Variables
    Dim oWrdDoc As Word.Document
    Dim oWdEditor As Word.Editors
   
    ' Get the Active Inspector
    Set OutInsp = OutMail.GetInspector
   
    ' Get the document within the inspector
    Set oWrdDoc = OutInsp.WordEditor
       
    ' Greetings
    Dim bodyMessage As String
    bodyMessage = "Hi Kapcer," & vbNewLine
    oWrdDoc.Range.InsertBefore bodyMessage
    
    ' Paste the table
    olRng.Copy
    oWrdDoc.Range(Len(bodyMessage), Len(bodyMessage)).Paste
    
exitRoutine:
    Application.CutCopyMode = False
    
    ' clear
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set ws = Nothing
    
    Exit Sub
    
errHandler:
    ' Open immediate window to see the error
    Debug.Print Err.Number, Err.Description
    
    Resume exitRoutine
End Sub

使用所有相关行的单元格值创建一封电子邮件作为邮件 body

Create one email with cell values from all relevant rows as the mail body

email

excel

outlook

vba