Question

我有提及代码，它可以很好地处理独特的记录，但唯一的问题是它会向1个电子邮件ID发送多封电子邮件。

电子邮件ID是n列W（第一条记录是w6），邮件正文位于第x6列将正文与代码"wsht.cells(i, 25) = sbody"

合并

任何想法，这将是谁将发送1封电子邮件

例如： - 在w7中，电子邮件ID为xxx@gmail.com，在w10中，电子邮件ID为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

您的问题正在发生，因为您正在测试这是否是第一次使用该电子邮件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

Outlook电子邮件宏

1 个答案: