VBA根据工作表输入向员工发送电子邮件

Question

在我的工作表中，主用户正在为每位员工提供信息 - 更确切地说，员工是否在月底交付了两份表格。

我想要实现的是提醒 - 电子邮件发送给Sheet1上列出的所有人，他的行中的答案为“否” - 所以他/她没有递交表格。

但是，在发送电子邮件之前，我不知道如何为所有缺少的文档存储信息 。因此，在我目前的循环中，如果一个员工在几个月内忘记交出2-3份文件，他/她将获得2-3个不同的电子邮件。

所以看下面的图片，Maxime Musterman会收到一封电子邮件说：

“嘿马克西姆，

我仍然想念你：

• 8月16日暂无出口

• 从9月16日开始没有出口

谢谢“

也许你们中的一个可以提供帮助？

我是VBA的新手，并从另一个网站获得了电子邮件发送代码。

提前致谢！

'----------------------------------------------------------------------------------------------------------------
'#################Set Email Conditions#################
'----------------------------------------------------------------------------------------------------------------

Dim CDO_Mail As Object
Dim CDO_Config As Object
Dim SMTP_Config As Variant
Dim strSubject As String
Dim strFrom As String
Dim strTo As String
Dim strCc As String
Dim strBcc As String
Dim strBody As String

Set CDO_Mail = CreateObject("CDO.Message")

Set CDO_Config = CreateObject("CDO.Configuration")
CDO_Config.Load -1

Set SMTP_Config = CDO_Config.Fields

With SMTP_Config
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.metrocast.net"
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    .Update
End With

'----------------------------------------------------------------------------------------------------------------
'#################Find who needs a Reminder-Email#################
'----------------------------------------------------------------------------------------------------------------

Dim ws As Worksheet, wsOutput As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")
Set wsOutput = ActiveWorkbook.Worksheets("Sheet2")
Dim MonthYearInput As String, recipientName As String, recipientEmail As String
Dim Employee As Range, DocsInMonth As Range
Dim lRow As Long, lcol As Long, NextRow As Long

lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
lcol = ws.Cells(11, Columns.Count).End(xlToLeft).Column


For Each Employee In ws.Range(Cells(12, 1), Cells(lRow, 1))
    For Each DocsInMonth In ws.Range(Cells(Employee.Row, 4), Cells(Employee.Row, lcol))

        If ws.Cells(Employee.Row, DocsInMonth.Column) = "No" And _
        DateValue(ws.Cells(10, DocsInMonth.Column)) >= DateValue(ws.Cells(Employee.Row, 3)) Then

            recipientName = ws.Cells(Employee.Row, 1)
            recipientEmail = ws.Cells(Employee.Row, 2)

            'How to store the information regarding all missing infos before sending it
            'to avoid sending 2-3 Emails to the same person?

            strSubject = "Results from Excel Spreadsheet"
            strFrom = "me@gmail.com"
            strTo = recipientEmail
            strCc = ""
            strBcc = ""
            strBody = "Hey " & recipientName & vbNewLine & vbNewLine & vbNewLine & _
                      "I am still missing INFO INFO INFO"

            With CDO_Mail
                Set .Configuration = CDO_Config
            End With

            CDO_Mail.Subject = strSubject
            CDO_Mail.From = strFrom
            CDO_Mail.To = strTo
            CDO_Mail.TextBody = strBody
            CDO_Mail.CC = strCc
            CDO_Mail.BCC = strBcc
            CDO_Mail.Send

        End If
    Next DocsInMonth
Next Employee

----------------------------------------------- -------------------------------------------------- -------

修改

我尝试了另一种方法，将所有带有“否”的条目复制到第二张工作表上，然后将Sheet2附加到电子邮件中。但是，我在此声明中收到运行时错误13“类型不匹配”：

If ws.Cells(Employee.Row, DocsInMonth.Column) = "No" And _
        DateValue(ws.Cells(10, DocsInMonth.Column)) >= DateValue(ws.Cells(Employee.Row, 3)) Then

代码：

Dim ws As Worksheet, wsOutput As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")
Set wsOutput = ActiveWorkbook.Worksheets("Sheet2")
Dim recipientName As String, recipientEmail As String
Dim Employee As Range, DocsInMonth As Range
Dim lRow As Long, lcol As Long, NextRow As Long

lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
lcol = ws.Cells(11, Columns.Count).End(xlToLeft).Column


For Each Employee In ws.Range(Cells(12, 1), Cells(lRow, 1))
    For Each DocsInMonth In ws.Range(Cells(Employee.Row, 4), Cells(Employee.Row, lcol))
        If ws.Cells(Employee.Row, DocsInMonth.Column) = "No" And _
        DateValue(ws.Cells(10, DocsInMonth.Column)) >= DateValue(ws.Cells(Employee.Row, 3)) Then

            NextRow = wsOutput.Range("A" & Rows.Count).End(xlUp).Row + 1
            ws.Cells(Employee.Row, 1).Copy Destination:=wsOutput.Cells(NextRow, 1) 'Name
            ws.Cells(10, DocsInMonth.Column).Copy Destination:=wsOutput.Cells(NextRow, 2) 'Month
            ws.Cells(11, DocsInMonth.Column).Copy Destination:=wsOutput.Cells(NextRow, 3) 'What


        End If
    Next DocsInMonth
Next Employee

Answer 1

在您的第二次尝试中，使用合并单元格可能存在问题，并且当DocsInMonth.Column是奇数列（例如，列E，G等）时，此行可能会抛出错误。 If语句的这一部分将引发错误：

DateValue(ws.Cells(10, DocsInMonth.Column))

原因是，当DocsInMonth.Column = 5时，ws.Cells(10,5)是合并范围的一部分，实际上该单元格 E5 中的值为空，该值仅存在于 D5 。

中

这应解决它，强制代码查看MergeArea中的第一个单元格：

DateValue(ws.Cells(10, DocsInMonth.Column).MergeArea.Cells(1).Value)