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

时间:2018-05-24 13:51:51

标签: excel vba excel-vba outlook

所以我有一个按案例分类的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函数中的文本之间显示信息?This is what my excel sheet looks like 只有在设计状态时才会发送电子邮件,并且电子邮件的文本大致如下所示 亲爱的(F2), 这提醒你,你的dcp(A2)(b2)应该是(G2), 你的Dcp(a3)(b3)到期了(g3) error 13 screenshot

3 个答案:

答案 0 :(得分:1)

这是一种通用方法,因为我们没有您的实际数据。

据我了解,您正在创建案例数据的循环作为开始。这不是恕我直言的好方法;如果您在电子邮件数据中设置第一个循环,那么在案例数据中设置第二个循环将更容易处理案例。第二个循环将每个case添加到一个字符串,之后将用作邮件正文。条件是案件的电子邮件是否等于您在外面循环的电子邮件。

在为一封电子邮件构建正文后(如果正文不为空),您将调用电子邮件发送程序。

我希望这有帮助,如果没有尝试从您的数据中提供一些样本,那么我或之后可能会创建一个功能代码。

编辑:由于您没有单独的电子邮件地址列表,您应首先创建一个电子邮件数组,然后将该列表用作外部循环。我没有机会尝试但是下面的代码应该以某种方式帮助你开始循环,电子邮件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

答案 1 :(得分:0)

好的,这是一个可能适合您的解决方案的拼凑版本。我注意到你错过了一个循环的想法,所以我希望你至少可以使用它来使它做你正在寻找的东西!

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

答案 2 :(得分:0)

@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