Outlook電子郵件宏

我有提到的代碼，它的獨特記錄工作得很好，但唯一的問題是它發送多個電子郵件到1個電子郵件ID。Outlook電子郵件宏

電子郵件ID是N型柱W（第1記錄W6）和郵件的身體是在列5233 有代碼"wsht.cells(i, 25) = sbody"

任何想法，誰將會這項工作是它西港島線發送1個郵件合併體

例如： - 在w7電子郵件ID是[email protected]，在w10電子郵件ID是[email protected] 當前代碼＃發送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

來源

2016-11-10 vmjan02

創建集合，數組或字典中存儲的每個電子郵件地址由代碼讀取。如果電子郵件地址尚不存在，請發送電子郵件。如果電子郵件地址已存在，則不要發送（重複）電子郵件。 –

你的問題發生，因爲你正在測試這是否是第一次的電子郵件ID已被使用，如果不是的話，你再發你設置的最後一封電子郵件。需要

的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

來源

2016-11-10 20:12:54 YowE3K

Outlook電子郵件宏

回答

相關問題