Excel Outlook电子邮件宏

我有提到的代码，它与唯一的记录都很好，但唯一的问题是它发送多封电子邮件到一个电子邮件id

电子邮件ID位于n列W（第一条记录为w6），邮件正文位于x6列 将主体与代码“wsht.cells（i，25）=sbody”合并

你知道谁会做这项工作吗？我会发一封电子邮件

例如：-在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

---

您的问题之所以出现，是因为您正在测试这是否是第一次使用电子邮件id，如果不是，则是重新发送您设置的最后一封电子邮件

测试的

结束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

Private子命令按钮3\u单击（）
Dim OutApp作为对象
将邮件变暗为对象
Set-OutApp=CreateObject（“Outlook.Application”）
应用
.EnableEvents=False
.ScreenUpdate=False
以
将wSht设置为工作表
暗淡的最后一排和长的一样，长的一样
Dim i为整数，k为整数
Dim sTo作为字符串，SSObject作为字符串，sBody作为字符串
设置wSht=ActiveSheet
LastRow=单元格（Rows.Count，1）.End（xlUp）.Row
从i=6到最后一行
lCuenta=Application.WorksheetFunction.CountIf（范围（“W6:W”和i）、范围（“W”和i））
如果LCA=1，则
ssObject=“PD回拨”
sTo=wSht.单元（i，1）
sBody=wSht.单元（i，24）
对于k=i到最后一行
如果wSht.Cells（i，1）.Value=wSht.Cells（k+1，1）.Value，则
sBody=sBody&vbNewLine&wSht.Cells（k+1,24）.Value
如果结束
wSht.细胞（i，25）=小体
下一个k
“如果结束”创建一个集合、数组或字典，以存储代码读取的每个电子邮件地址。如果电子邮件地址不存在，则发送电子邮件。如果电子邮件地址已经存在，则不要发送（重复的）电子邮件。