Отправлять почтовую почту с помощью Excel VBA

-3

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

Условия:

Колонка U содержит окончательный статус (Open или WIP) (не будет посылать если закрыт независимо от того, если текущая дата больше)
Колонка Q содержит дату закрытия. Что по сравнению с текущей датой, если меньше, чем автоматическая рассылка писем людям.

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

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

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

Dim rng As Range 
Dim OutApp As Object 
Dim OutMail As Object 
Dim StrBody As String 
Dim x As Variant 
Dim arr1 As Variant 

Dim i As Long, r As Long 

On Error Resume Next 
arr1 = Worksheets("Data").Range("Q2:Q" & Range("Q" & Rows.Count).End(xlUp).row).Value 
i = 1 
For Each x In arr1 
    For r = 1 To 2 

     If x < Now() Then 


     If Sheets("Data").Worksheets("Data").Cells(i, "U").Value = "Open" 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) 

    With OutMail 


      If Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "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

источник

2016-06-22 Mehul Rastogi

В этом коде нет цикла. Почему вы ожидаете, что он переместится в другую строку? –

@MacroMan Я удалил цикл for, а затем вставил. –

Хорошо, что мы не можем использовать код, который мы не можем видеть сейчас, можем ли мы ... на другом примечании, вы просто игнорируете ошибки в своем коде, а не имеете дело с ними, что также не дает возможности помочь. –

Решено: Это позволит решить проблему выше.

Sub Data_RoundedRectangle1_Click() 
Dim OutApp As Object 
Dim OutMail As Object 
Dim rng As Range 

For i = 2 To Cells(Rows.Count, 1).End(xlUp).row 

If Cells(i, 21).Value = "Open" And Cells(i, 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("Data").Range("C1:V5").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 Cells(i, 3).Value = "Operation_Support" And Cells(i, 5).Value = "Quality_Assurance" Then 


     StrBody = "Hi," & "<br>" & _ 
      "PFB the process details which requires your attention." & "<br>" & _ 
      "The review for this process has crossed overdue." & "<br>" & _ 
      "Please ask the process owner to review the Process Manuals and Maps." & "<br><br><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 Cells(i, 3).Value = "Operation_Support" And Cells(i, 5).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 = "s" 
    .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 

End If 
End With 


On Error GoTo 0 

Set OutMail = Nothing 
Set OutApp = Nothing 

End If 
Next i 

End Sub

источник

2016-06-24 10:23:04

Отправлять почтовую почту с помощью Excel VBA

ответ

Смежные вопросы