рассеянный список адресов электронной почты в 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 Письмо нужно отправлять только в том случае, если статус задан, иТекст электронного письма выглядит примерно так: Уважаемый (F2), Это напоминание о том, что ваш dcp (A2) (b2) из-за (G2), ваш Dcp (a3) ​​(b3) из-за (g3) ошибка 13, снимок экрана

Answer 1

Хорошо, вот вам составленная версия решения, которое может работать на вас.Я заметил, что вам не хватало идеи цикла, поэтому я надеюсь, что вы хотя бы сможете поработать с этим, чтобы он делал то, что вы ищете!

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 2

@ хакан

    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

Answer 3

Это будет общий подход, поскольку у нас нет ваших фактических данных.

Насколько я понимаю, для начала вы создаете цикл для данных случаев.Это не очень хороший способ ИМХО;если вы установите свой первый цикл в данных электронной почты, а затем установите второй цикл в данных дел, это будет намного проще обрабатывать дело.Второй цикл добавляет каждый случай к строке, которая впоследствии будет использоваться в качестве почтового тела.Условием является то, соответствует ли электронная почта дела тому, что вы зацикливаете за пределами.

После создания тела для одного электронного письма (и если тело не является нулевым), вы вызоветепроцедура отправки электронной почты.

Надеюсь, это поможет, если не попытаться предоставить образец из ваших данных, который я или кто-то мог бы создать функциональный код после этого.

РЕДАКТИРОВАТЬ: Так как у вас нет отдельной электронной почтысписок адресов, сначала вы должны создать массив писем, а затем использовать этот список в качестве внешнего цикла.У меня нет шансов попробовать, но приведенный ниже код должен как-то помочь вам начать работу с циклами, построением бодов по электронной почте и т. Д .:

 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