☰

Отправка массовой почты с помощью Excel VBA

tag-icon • tag-icon vba microsoft-excel-2013 macros
Отправка массовой почты с помощью Excel VBA

Работал над проектом, который будет отправлять массовые письма разным людям, если будут соблюдены условия.

Условия :

  • Столбец U содержит окончательный статус (Открыто или Незавершенное) (не будет отправлено, если Закрыто, независимо от того, больше ли текущая дата)
  • Столбец Q содержит дату закрытия. Которая при сравнении с текущей датой, если меньше, то автоматическая отправка писем людям.

Я пытался сделать с циклом for, но он выдает 4 письма с одинаковыми To и CC. И не переходит к следующей строке для сравнения.

Сравнение ячеек V2 с Q2, затем следующий цикл V3 с Q3 и с той же стороны проверяем, имеет ли ячейка U2 значение «Открыто»

Заранее спасибо.

Код, как показано ниже:

Sub Data_RoundedRectangle1_Click()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String



On Error Resume Next

For i = 1 to 4

If Sheets("Data").Range("U2:U6").Value2 = "Open" Or     Sheets("Data").Range("U2:U6").Value2 = "WIP" And (CDate(Cells(2, 17).Value) <     Now()) Then



        Set rng = Nothing
        On Error Resume Next
        'Only the visible cells in the selection
        Set rng = Selection.SpecialCells(xlCellTypeVisible)
        'You can also use a fixed range if you want
        Set rng = Sheets("Checklist").Range("A2:B25").SpecialCells(xlCellTypeVisible)
        On Error GoTo 0


        With Application
        .EnableEvents = False
        .ScreenUpdating = False
        End With

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        On Error Resume Next

With OutMail


        If Worksheets("Data").Cells(i, "C").Value2 = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value2 = "Quality_Assurance" Then


     StrBody = "Hi," & "<br>" & _


.To = "a"

.CC = "b"
.BCC = ""
.Subject = ""
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send

ElseIf Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "Analytics" Then

StrBody = "Hi," & "<br>" & _
      "PFB the process details which requires your attention." & "<br>" & _
      "The review for this process has crossed over due." & "<br>" & _
      "Please ask the process owner to review the Process Manuals and Maps."     & "<br><br><br>"

.To = "c"

.CC = "d"
.BCC = ""
.Subject = "Process Manual and Maps Review is Overdue"
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send

End If

    End With

    i = i + 1
    Exit For

    End If
End If

Next r

On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

Next x
End Sub

введите описание изображения здесь

решение1

Я думаю, это из-за твоего цикла.

For i = 1 to 4

Но вы никогда не ссылаетесь i, поэтому это происходитвсеЧетыре раза. Вы должны использовать это так, а не так -

If Sheets("Data").cells(21,1+i).Value2 = "Open" Or Sheets("Data").cells(21,1+i).Value2 = "WIP" And ...

Я не совсем уверен, о чем идет речь во второй части вашего ifфразы, но суть вы уловили.

Связанный контент