做循环按行发送多个电子邮件

Question

我正在寻找一些VBA代码的帮助。

我有一个包含多个列和行的Excel工作表。每行代表一个不同的报告，我必须创建并通过电子邮件发送给特定的收件人。每份报告都是特定的工作日。我要做的是以下内容。自动为给定工作日中的每一行创建电子邮件。我在下面粘贴的代码非常适合创建一封电子邮件，但我想避免每行都有一个宏按钮。

我希望代码在给定的工作日中为每一行循环。例如，如果营业日1有10个报告，则单击该宏将生成10个不同的唯一电子邮件。

我试图创建一个do while循环，但我遇到了一些问题，我不知道如何解决连接文本单元格的主题和正文，每行都是唯一的。

Sub makeReports(dueDate As Date)

Dim reportsRange As Range
Dim xlCell As Range

Dim objOutlook As Outlook.Application
Dim strTo As String
Dim strCc As String
Dim strSubject As String
Dim strBody As String

'Determine reports range (from uppermost cell to last nonempty cell in column)
Set reportsRange = Range("B5", Range("B" & Cells.Rows.Count).End(xlUp))


Set objOutlook = CreateObject("Outlook.Application")

For Each xlCell In reportsRange
    If xlCell.Value = dueDate Then
        strTo = xlCell.Offset(0, 5).Value
        strCc = xlCell.Offset(0, 6).Value
        strSubject = xlCell.Offset(0, 10).Value
        strBody = xlCell.Offset(0, 11).Value

        Call createMail(objOutlook, strTo, strCc, strSubject, strBody)
    End If

Next xlCell

Set objOutlook = Nothing

End Sub


 Sub createMail(objOutlook As Outlook.Application, strTo As String, strCc As String, strSubject   As String, strBody As String)

Dim objMail As Outlook.MailItem

Set objMail = objOutlook.CreateItem(0)


With objMail
    .To = strTo
    .cc = strCc
    .Subject = strSubject
    .Body = strBody
    .display
    ' If you want to send:
    '.Send
End With

Set objMail = Nothing

End Sub


Sub test()
  Call makeReports(1)
End Sub

Private Sub CommandButton1_Click()
  Call makeReports(Date)
End Sub

第三次修改：

我附上了工作日功能的屏幕截图，以确定正确的可交付日期

截图

Answer 1

假设您在某个工作日的报告存储在A列中，以下代码可以帮助您入门：

Sub SendReports(columnLetter As String)

    Dim reportsRange As Range
    Dim xlCell As Range

    'Determine reports range (from uppermost cell to last nonempty cell in column)
    Set reportsRange = Range(columnLetter & "1", Range(columnLetter & Cells.Rows.Count).End(xlUp))

    For Each xlCell In reportsRange
        Call CreateMail(xlCell.value)
    Next xlCell

End Sub

测试它：

Sub test()
 Call SendReports("A")
End Sub

只需更改CreateMail即可接受rngBody作为参数。

修改

以下代码适用于我的电脑。确保设置对Outlook对象库的引用（在VBA编辑器中，选择工具＆gt;引用并勾选Microsoft Outlook ##。＃Object Library（其中##。＃是您安装的版本））并删除所有空的报表行A栏。

  Sub makeReports(businessDay As Integer)

    Dim reportsRange As Range
    Dim xlCell As Range

    Dim objOutlook As Outlook.Application
    Dim strTo As String
    Dim strCc As String
    Dim strSubject As String
    Dim strBody As String

    'Determine reports range (from uppermost cell to last nonempty cell in column)
    Set reportsRange = Range("A5", Range("A" & Cells.Rows.Count).End(xlUp))


    Set objOutlook = CreateObject("Outlook.Application")

    For Each xlCell In reportsRange
        If xlCell.Value = businessDay Then
            strTo = xlCell.Offset(0, 4).Value
            strCc = xlCell.Offset(0, 5).Value
            strSubject = xlCell.Offset(0, 8).Value
            strBody = xlCell.Offset(0, 7).Value

            Call createMail(objOutlook, strTo, strCc, strSubject, strBody)
        End If

    Next xlCell

    Set objOutlook = Nothing

End Sub


Sub createMail(objOutlook As Outlook.Application, strTo As String, strCc As String, strSubject As String, strBody As String)

    Dim objMail As Outlook.MailItem

    Set objMail = objOutlook.CreateItem(0)


    With objMail
        .To = strTo
        .cc = strCc
        .Subject = strSubject
        .Body = strBody
        .display
        ' If you want to send:
        '.Send
    End With

    Set objMail = Nothing

End Sub


Sub test()
 Call makeReports(1)
End Sub

现在你所需要的只是找出当前工作日的一些逻辑。

<强> EDIT2：

这是代码的修改版本，接受截止日期作为参数，并考虑到您插入的其他列：

  Sub makeReports(dueDate As Date)

    Dim reportsRange As Range
    Dim xlCell As Range

    Dim objOutlook As Outlook.Application
    Dim strTo As String
    Dim strCc As String
    Dim strSubject As String
    Dim strBody As String

    'Determine reports range (from uppermost cell to last nonempty cell in column)
    Set reportsRange = Range("B5", Range("B" & Cells.Rows.Count).End(xlUp))


    Set objOutlook = CreateObject("Outlook.Application")

    For Each xlCell In reportsRange
        If xlCell.Value = dueDate Then
            strTo = xlCell.Offset(0, 4).Value
            strCc = xlCell.Offset(0, 5).Value
            strSubject = xlCell.Offset(0, 8).Value
            strBody = xlCell.Offset(0, 7).Value

            Call createMail(objOutlook, strTo, strCc, strSubject, strBody)
        End If

    Next xlCell

    Set objOutlook = Nothing

End Sub

在工作表上添加一个命令按钮，然后输入以下代码：

Private Sub CommandButton1_Click()
  Call makeReports(Date)
End Sub

这应该为今天到期的每份报告打开一封邮件。