Outlook Email Macro

Question

У меня есть код упоминания, и он хорошо работает с уникальными записями, но единственная проблема заключается в отправке нескольких сообщений электронной почты на один идентификатор электронной почты.

Email ID является п столбцов W (первая запись W6) и тело почты в колонке x6 есть слияние тела с кодом "wsht.cells(i, 25) = sbody"

любой идея, кто будет эта работа была Виль отправить 1 письмо,

например: - в w7 идентификатор электронной почты - xxx@gmail.com, а в w10 идентификатор электронной почты - xxx@gmail.com В настоящее время код # отправляет 2 письма, но он должен отправлять только 1 письмо на адрес xxx @ gmail. com

Любая идея или обновление.

Private Sub CommandButton3_Click() 
Dim OutApp As Object 
Dim OutMail As Object 

Set OutApp = CreateObject("Outlook.Application") 

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

Dim wSht As Worksheet 
Dim LastRow As Long, lCuenta As Long 
Dim i As Integer, k As Integer 
Dim sTo As String, sSbject As String, sBody As String 

Set wSht = ActiveSheet 
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 

For i = 6 To LastRow 
    lCuenta = Application.WorksheetFunction.CountIf(Range("W6:W" & i), Range("W" & i)) 
    If lCuenta = 1 Then 
    ssubject = "PD Call Back" 
    sTo = wSht.Cells(i, 1) 
    sBody = wSht.Cells(i, 24) 
    For k = i To LastRow 
     If wSht.Cells(i, 1).Value = wSht.Cells(k + 1, 1).Value Then 
     sBody = sBody & vbNewLine & wSht.Cells(k + 1, 24).Value 
     End If 
     wSht.Cells(i, 25) = sBody 
    Next k 
    End If 

    Set OutMail = OutApp.CreateItem(0) 

    On Error Resume Next 
    With OutMail 
    .To = sTo 
    .Subject = ssubject 
    .body = sBody 
    .Send 
    End With 
Next i 
End Sub 

Answer 1

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

End If для теста должен быть перемещен после раздела, который отправляет электронную почту:

Private Sub CommandButton3_Click() 
    Dim OutApp As Object 
    Dim OutMail As Object 

    Set OutApp = CreateObject("Outlook.Application") 

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

    Dim wSht As Worksheet 
    Dim LastRow As Long, lCuenta As Long 
    Dim i As Integer, k As Integer 
    Dim sTo As String, sSbject As String, sBody As String 

    Set wSht = ActiveSheet 
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row 

    For i = 6 To LastRow 
     lCuenta = Application.WorksheetFunction.CountIf(Range("W6:W" & i), Range("W" & i)) 

     If lCuenta = 1 Then 
      ssubject = "PD Call Back" 
      sTo = wSht.Cells(i, 1) 
      sBody = wSht.Cells(i, 24) 

      For k = i To LastRow 
       If wSht.Cells(i, 1).Value = wSht.Cells(k + 1, 1).Value Then 
        sBody = sBody & vbNewLine & wSht.Cells(k + 1, 24).Value 
       End If 
       wSht.Cells(i, 25) = sBody 
      Next k 

     'End If '<-- Move this 

      Set OutMail = OutApp.CreateItem(0) 

      On Error Resume Next 
      With OutMail 
       .To = sTo 
       .Subject = ssubject 
       .body = sBody 
       .Send 
      End With 

     End If '<-- To here 
    Next i 
End Sub