在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