执行 While 循环以按行发送多封电子邮件

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 编辑器中，选择工具>引用并勾选 Microsoft Outlook ##.# 对象库（其中 ##.# 是您安装的版本））并删除所有空的报告行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

现在您只需要一些逻辑来计算当前工作日。

编辑2：

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

  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

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