在excel上分散的电子邮件列表，如何每人发送一封电子邮件？ 以及如何在电子邮件正文中包含单元格的内容

Question

So I have an excel sheet organized by case that are assigned to emails. Each case is assigned to one email and each email is responsible for more than one case. Emails are not in order, they are scattered throughout the column. I want to create an automated email that sends a reminder every Monday (this I havent figured out how yet) to submit the case. Problem is I want to send one email per person regrouping all the cases assigned to them that are due. (When a case is closed it disappears from the sheet so no need to worry about this).

Here's what I already wrote:

    Sub datesexcelvba()

Dim myApp As Outlook.Application, mymail As Outlook.MailItem
Dim mydate1 As Date
Dim mydate2 As Long  
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim engineer As Range

Dim x As Long
lastrow = Sheets("Messages english").Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lastrow

mydate1 = Cells(x, 3).Value
mydate2 = mydate1
Cells(x, 7) = mydate2

datetoday1 = Date
datetoday2 = datetoday1


Cells(x, 9).Value = datetoday2
Set daysLeft = mydate2 - datetoday2

Function itsokay()
If daysLeft <= 14 And daysLeft >= 8 Then
Set myApp = New Outlook.Application
Set mymail = myApp.CreateItem(olMailItem)

mymail.To = Cells(x, 2).Value
'.send


    With mymail
    .Subject = (xx)
    .Body =  (Message) (content of a cell) (message)...etc
    .Display
    End With

Cells(x, 10) = Date
Cells(x, 10).Interior.ColorIndex = 3
Cells(x, 10).Font.ColorIndex = 2
Cells(x, 10).Font.Bold = True

End If
End Function


Function comeon()
If daysLeft <= 7 And daysLeft >= 4 Then
Set myApp = New Outlook.Application
Set mymail = myApp.CreateItem(olMailItem)

mymail.To = Cells(x, 2).Value
'.send


    With mymail
    .Subject = (xx)
    .Body =  (Message) (content of a cell) (message)...etc
    .Display
    End With

Cells(x, 11) = Date
Cells(x, 11).Interior.ColorIndex = 3
Cells(x, 11).Font.ColorIndex = 2
Cells(x, 11).Font.Bold = True

End If
End Function
 Function late()
If daysLeft < 4 Then
Set myApp = New Outlook.Application
Set mymail = myApp.CreateItem(olMailItem)

mymail.To = Cells(x, 2).Value
'.send


    With mymail
    .Subject = (xx)
    .Body = (Message) (content of a cell) (message)...etc
    .Display
    End With

Cells(x, 12) = Date
Cells(x, 12).Interior.ColorIndex = 3
Cells(x, 12).Font.ColorIndex = 2
Cells(x, 12).Font.Bold = True

End If
End Function

engineer = Cell(x, 6).Value
If engineer = "PLM" Then
// here i should write the code that sends each email(functions created above to the engineer) 

Next

Set myApp = Nothing
Set mymail = Nothing

End Function

Thank you !! One last question: How can i show the info in a cell in between text in the .Body function?? This is what my excel sheet looks like The email has to be sent only when status is design, and the text of the email roughly look like this Dear (F2), This is a reminder that your dcp (A2) (b2) is due on the (G2), your Dcp (a3) (b3) is due on the (g3) error 13 screenshot

Answer 1

This will be a general approach since we do not have your actual data.

As far as I understand you are creating a loop on the cases data as a start. This is not a good way IMHO; if you set your first loop within e-mails data, then set a second loop within the cases data it will be much easier to handle the case. The second loop adds each case to a string which will be used as the mail body afterwards. The condition is whether the e-mail of the case is equal to the one you are looping outside.

After constructing the body for one e-mail (and if the body is not null), you will call the e-mail sending procedure.

I hope this helps, if not try providing some sample from your data which I or someone might create a functional code after then.

EDIT: Since you do not have a seperate e-mail addresses list, you shoul first create an array of the e-mails and then use that list as the outer loop. I don't have the chance of trying but below code should somehow help you to get a start on the loops, e-mail bodt construction etc:

 Sub datesexcelvba()
 ' create a dictionary object of unique e-mails
     Dim d As Object, c As Range, k, tmp As String

    Set d = CreateObject("scripting.dictionary")
    For Each c In Range("H:H").Cells
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c

    For Each k In d.keys
     ' This is the outer loop of e-mails, the body shoul be constructed here and the e-mail should be sent at the end.
     ' I am keeping your inner loop since I assume that there is no problem with it
        lastrow = Sheets("Messages english").Cells(Rows.Count, 1).End(xlUp).Row
            For x = 2 To lastrow

                If Cells(x, 4).Value = "Design" And Cells(x, 8).Value = k Then
                    myMail.Body = "Dcp No:" & Cells(x, 1).Value
                    myMail.Body = myMail.Body & " | Desc:" & Cells(x, 2).Value
                    myMail.Body = myMail.Body & " | Due Date:" & Cells(x, 7).Value
                    myMail.Body = myMail.Body & Chr(13) 'line feed
                 End If



            Next x
         If myEmail.Body <> "" Then Send_Mail k, "Task is due!", myMail.Body
    Next k


 End Sub

Function Send_Mail(ByVal email_recipient As String, ByVal email_subject, ByVal email_body As String)

    Dim myApp As Outlook.Application
    Set myApp = New Outlook.Application

    Dim myMail As Outlook.MailItem
    Set myMail = myApp.createItem(olMailItem)

    With myMail
        .To = email_recipient
        .Subject = email_subject
        .Body = email_body
        '.Display
    End With

    Set myMail = Nothing
    Set myApp = Nothing

End Function

Answer 2

Okay so here's a pieced together version of a solution that might work for you. I noticed that you were missing the idea of a loop so I hope that you can at least work with this to make it do what you're looking for!

Sub DCP_Emails()

    Dim mydate1 As Date
    Dim mydate2 As Long
    Dim datetoday1 As Date
    Dim datetoday2 As Long
    Dim daysLeft As Integer

    Dim lastRow As Integer
    lastRow = Sheets("Messages english").Cells(Rows.Count, 1).End(xlUp).Row

    Dim x As Integer
    For x = 2 To lastRow

        mydate1 = Cells(x, "C").value
        mydate2 = mydate1
        Cells(x, "G") = mydate2

        datetoday1 = Date
        datetoday2 = datetoday1


        Cells(x, "I").value = datetoday2
        daysLeft = mydate2 - datetoday2

        If LCase$(Cells(x, "D").Value2) = "design" Then
            If daysLeft <= 14 And daysLeft >= 8 Then
                Send_Mail Cells(x, "H").Value2, "DCP Reminder - Priority: Low", _
                        "Dear " & Cells(x, "F") & ", " & Chr(10) & Chr(10) & _
                        "This is a reminder that your DCP " & Cells(x, "A") & " " & Cells(x, "B") & " is due on " & Cells(x, "G")

            ElseIf daysLeft <= 7 And daysLeft >= 4 Then
                Send_Mail Cells(x, "H").Value2, "DCP Reminder - Priority: Medium", _
                        "Dear " & Cells(x, "F") & ", " & Chr(10) & Chr(10) & _
                        "This is a reminder that your DCP " & Cells(x, "A") & " " & Cells(x, "B") & " is due on " & Cells(x, "G")

            Else
                Send_Mail Cells(x, "H").Value2, "DCP Reminder - Priority: High", _
                        "Dear " & Cells(x, "F") & ", " & Chr(10) & Chr(10) & _
                        "This is a reminder that your DCP " & Cells(x, "A") & " " & Cells(x, "B") & " is due on " & Cells(x, "G")

            End If

            With Cells(x, "J")
                .Value2 = Date
                .Interior.ColorIndex = 3
                .Font.ColorIndex = 2
                .Font.Bold = True
            End With
        End If

    Next x

    Set myApp = Nothing

End Sub

Function Send_Mail(ByVal email_recipient As String, ByVal email_subject, ByVal email_body As String)

    Dim myApp As Outlook.Application
    Set myApp = New Outlook.Application

    Dim myMail As Outlook.MailItem
    Set myMail = myApp.createItem(olMailItem)

    With myMail
        .To = email_recipient
        .Subject = email_subject
        .Body = email_body
        '.Display
    End With

    Set myMail = Nothing
    Set myApp = Nothing

End Function

Answer 3

@hakan

    Sub DCP_Emails()

Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim daysLeft As Long
 Dim lastRow As Long


Dim d As Object, c As Range, k, tmp As String

Set d = CreateObject("scripting.dictionary")
 For Each c In Range("H:H").Cells
 If c.Value <> "N/A" Then
    tmp = Trim(c.Value)
    If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
  Next c




 For Each k In d.keys
lastRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row

Dim x As Long
For x = 2 To lastRow
    If Cells(x, 7).Value <> " " Then
        mydate1 = Cells(x, 7).Value
        mydate2 = mydate1
        Cells(x, "J") = mydate2

        datetoday1 = Date
        datetoday2 = datetoday1


        Cells(x, "K").Value = datetoday2
        daysLeft = mydate2 - datetoday2






        If LCase$(Cells(x, "D").Value2) = "design" And Cells(x, 8).Value = k Then

            If daysLeft <= 14 And daysLeft >= 8 Then

          Send_Mail k.Value2, "DCP Reminder - Priority: Low", _
         "Dear " & Cells(x, "F") & ", " & Chr(10) & Chr(10) & _
          "This is a reminder that your DCP " & Cells(x, "A") & " " & Cells(x, "B") & " is due on " & Cells(x, "G")

            End If


            With Cells(x, "L")
                .Value2 = Date
                .Interior.ColorIndex = 3
                .Font.ColorIndex = 2
                .Font.Bold = True
            End With
        End If
End If

Next x
Next k


Set myApp = Nothing

End Sub

Function Send_Mail(ByVal email_recipient As String, ByVal email_subject, ByVal email_body As String)

Dim myApp As Object
Set myApp = CreateObject("Outlook.Application")

Dim myMail As Object
Set myMail = myApp.createItem(0)

With myMail
    .To = email_recipient
    .Subject = email_subject
    .Body = email_body
    .Send
    '.Display
End With

Set myMail = Nothing
Set myApp = Nothing

End Function