通过VBA发送多封电子邮件

我尝试了以下代码（我更改了真实的电子邮件地址），它在范围内的第一个单元格上运行，但在第一个单元格之后，它给了我一个错误：“运行时错误，项目已被移动或删除”，然后，它不发送其他单元格。。。。我需要在代码中修复什么

Sub sendMailWithLoop()

    Dim missmatchCell As Range
    Dim Missmatches_Rng As Range
    Dim entityForRepeatedValues_Rng As Range
    Dim OutMail As Object
    Dim OutApp As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    If Range("D1000").End(xlUp).Value <> "Name" Then

        Set Missmatches_Rng = Range(Range("D1000").End(xlUp), Range("D1000").End(xlUp).End(xlUp).Offset(1, 0))

        Missmatches_Rng.Select

        For Each missmatchCell In Selection

            With OutMail    

                .To = "mymail@servername.com"
                .Subject = "Attention !! missmatch found"
                .Body = "The missmatch name is: " & missmatchCell.Offset(0, 1) & ", on: " & missmatchCell
                .Send   

            End With

        Next

    End If

End Sub

Sub-sendMailWithLoop（）
暗匹配单元格作为范围
变暗错误匹配为范围
重复值的Dim实体\u Rng As Range
将邮件变暗为对象
Dim OutApp作为对象
Set-OutApp=CreateObject（“Outlook.Application”）
Set-OutMail=OutApp.CreateItem（0）
如果范围为（“D1000”）.End（xlUp）.Value为“Name”，则
设置错误匹配\u Rng=范围（范围（“D1000”）。结束（xlUp），范围（“D1000”）。结束（xlUp）。结束（xlUp）。偏移量（1，0））
错误匹配\u Rng.Select
对于选择中的每个不匹配单元格
发邮件
.To=”mymail@servername.com"
.Subject=“注意！！发现不匹配”
.Body=“错误匹配的名称为：”&missmatchCell.Offset（0，1）&“，on:”&missmatchCell
.发送
以
下一个
如果结束
端接头

---

谢谢

将您的

Set-OutMail=OutApp.CreateItem（0）

移动到

的
中，如下所示：

Sub sendMailWithLoop()

    Dim missmatchCell As Range
    Dim Missmatches_Rng As Range
    Dim entityForRepeatedValues_Rng As Range
    Dim OutMail As Object
    Dim OutApp As Object

    Set OutApp = CreateObject("Outlook.Application")


    If Range("D1000").End(xlUp).Value <> "Name" Then

        Set Missmatches_Rng = Range(Range("D1000").End(xlUp), Range("D1000").End(xlUp).End(xlUp).Offset(1, 0))

        Missmatches_Rng.Select

        For Each missmatchCell In Selection
            Set OutMail = OutApp.CreateItem(olMailItem)
            With OutMail    

                .To = "mymail@servername.com"
                .Subject = "Attention !! missmatch found"
                .Body = "The missmatch name is: " & missmatchCell.Offset(0, 1) & ", on: " & missmatchCell
                .Send   

            End With

        Next

    End If

End Sub

Sub-sendMailWithLoop（）
暗匹配单元格作为范围
变暗错误匹配为范围
重复值的Dim实体\u Rng As Range
将邮件变暗为对象
Dim OutApp作为对象
Set-OutApp=CreateObject（“Outlook.Application”）
如果范围为（“D1000”）.End（xlUp）.Value为“Name”，则
设置错误匹配\u Rng=范围（范围（“D1000”）。结束（xlUp），范围（“D1000”）。结束（xlUp）。结束（xlUp）。偏移量（1，0））
错误匹配\u Rng.Select
对于选择中的每个不匹配单元格
Set-OutMail=OutApp.CreateItem（olMailItem）
发邮件
.To=”mymail@servername.com"
.Subject=“注意！！发现不匹配”
.Body=“错误匹配的名称为：”&missmatchCell.Offset（0，1）&“，on:”&missmatchCell
.发送
以
下一个
如果结束
端接头
它为oMailItem提供了一个错误。。。这到底意味着什么？我在网上找不到关于血统的解释。。。谢谢！对不起，我拼错了。无论如何，您也可以使用0。请参阅以获取进一步的解释。您能解释一下您是如何修复我的代码的吗？Set-OutMail=OutApp。CreateItem（OlMailItem）创建一个新的邮件项目。您需要创建与正在发送的邮件数量相同的邮件项目，因此将该行放在循环中会创建与您发送的邮件数量相同的邮件项目。当它在For循环之外时，您只是创建了一个邮件项，该邮件项仅适用于您发送的第一封邮件，一旦该循环第二次被命中，OutMail就已经消失了，因此导致代码失败。另一个。。如果我想创建另一个可能（或可能不，取决于条件的结果）也会发送电子邮件的条件，我如何创建这样的条件，使其不会干扰第一个条件中的对象定义（dim）？第二个条件不在第一个条件的循环中，它们之间没有连接（另一个IF条件…），thx！！