Outlookのメールマクロ

Question

私はコードを記述しており、一意のレコードでうまく動作しますが、唯一の問題は複数の電子メールを1つの電子メールIDに送信することです。

メールIDは（第一レコードがW6である）と、メールの本文が列X6 であるこの作品は、それが1通の電子メールを送信ウィルだっただろう誰とコード"wsht.cells(i, 25) = sbody"

で任意のアイデアをボディをマージしている列Wをn個

例えば： - 電子メールIDはxxx@gmail.comで、電子メールIDはxxx@gmail.comです 現在、コード＃は2つのメールを送信しますが、xxx @ gmailには1つのメールのみを送信します。 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

あなたは、これは電子メールIDが使用されたのは初めてであるかどうかをテストしていると、そうでない場合、あなたが設定し、最後のメールを再送しているので、あなたの問題が発生しています。コードで読み取り、各電子メールアドレスを格納するコレクション、配列、または辞書を作成

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