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

Question

In my Worksheet, a Master-User is putting in Information for every Employee - more precisely whether the Employees handed in two forms in the end of the month.

What I am trying to achieve is that a reminder-Email is send to everyone listed on Sheet1 who has the answer "No" in his row - so he/she did not hand in the form.

However, I do not know how to store the Information for all missing documents for one Employee before sending an Email to this Person. So in my current Loop, if an Employee forgot to Hand in 2-3 documents over the course of a few months, he/she would get 2-3 different Emails.

So looking at the picture below, Maxime Musterman would get an Email saying:

---

"Hey Maxime,

I am still missing your:

• Stmnt of no Export from Aug 16

• Stmnt of no Export from Sep 16

Thanks"

---

Maybe one of you could help?

I am new to VBA and got the Email-sending-Code from another Website.

Thanks in advance!

'----------------------------------------------------------------------------------------------------------------
'#################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

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

EDIT:

I tried another approach by copying all Entries with a "No" for an Employee onto the second Sheet and then attaching the Sheet2 to the Email. However, I am getting a Runtime Error 13 "Type Mismatch" at this statement:

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

Code:

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

In your second attempt, there is a potential problem with using merged cells, and this line will likely throw an error when DocsInMonth.Column is an odd number column (such as Column E, G, etc.). This part of your If statement will raise an error:

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

The reason being, when DocsInMonth.Column = 5, for example, then ws.Cells(10,5) is part of a merged range, and actually the value in that cell E5 is empty, the value exists only in D5 .

This should resolve it, by forcing the code to look at the first cell in the MergeArea :

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