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

Question

因此，我有一个按大小写组织的excel表，分配给电子邮件。 每个案例都分配给一封电子邮件，每封电子邮件负责一个以上的案例。 电子邮件不整齐，它们分散在整个列中。 我想创建一个自动电子邮件，该电子邮件在每个星期一发送提醒（我还没有弄清楚如何）以提交案件。 问题是我想每人发送一封电子邮件，将分配给他们的所有案件重新分组。 （当箱子关闭时，它会从工作表中消失，因此无需担心）。

这是我已经写的：

    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

谢谢 ！！ 最后一个问题：如何在.Body函数中的文本之间的单元格中显示信息？ 这就是我的excel工作表的样子电子邮件仅在状态为design时才必须发送，并且电子邮件的文本大致如下所示：亲爱的（F2），这提醒您dcp（A2）（b2）到期在（G2）上，您的Dcp（a3）（b3）是由于（g3） 错误13屏幕截图

Answer 1

由于我们没有您的实际数据，因此这将是一种通用方法。

据我了解，您正在以案例数据为起点创建循环。 恕我直言，这不是一个好方法； 如果您在电子邮件数据中设置了第一个循环，然后在案例数据中设置了第二个循环，则处理案例将更加容易。 第二个循环将每种情况添加到字符串中，然后将其用作邮件正文。 条件是该案例的电子邮件是否等于您要传递给外部的电子邮件。

在构造了一封电子邮件的正文之后（如果正文不为空），您将调用电子邮件发送过程。

希望这对您有所帮助，如果不尝试从您的数据中提供一些示例，则此后我或某人可能会创建一个功能代码。

编辑：由于您没有单独的电子邮件地址列表，因此您应该首先创建电子邮件的数组，然后将该列表用作外部循环。 我没有机会尝试，但是下面的代码应该可以以某种方式帮助您开始循环，电子邮件Bodt构建等工作：

 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

好的，这是一个可能适合您的解决方案的拼凑版本。 我注意到您错过了循环的想法，因此希望您至少可以使用它来使它完成您想要的工作！

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