Question

我正努力提高工作效率。为此，我们的任务是向人员列表发送电子邮件。

为此，我创建了以下代码。想知道这是否可以改善？此代码从工作簿中的工作表“Final_list”获取信息，标题位于第1行。

Sub EmailToAll()

    Dim outlookApp As Outlook.Application
    Dim outlookMail As Outlook.MailItem

    Set outlookApp = CreateObject("Outlook.Application")
    Set outlookMail = outlookApp.CreateItem(olMailItem)



    Dim sh As Worksheet
    Dim RowCount As Integer

    Worksheets("Final_List").Activate

    RowCount = 2

    Set sh = ActiveSheet

    Do While IsEmpty(sh.Cells(RowCount, 1).Value) = False

        Set outlookApp = CreateObject("Outlook.Application")
        Set outlookMail = outlookApp.CreateItem(olMailItem)
        With outlookMail
                'MsgBox sh.Cells(RowCount, 7).Value
                .To = sh.Cells(RowCount, 7).Value
                .CC = sh.Cells(RowCount, 9).Value
                .BCC = Empty
                .Subject = "[Update]" & " " & sh.Cells(RowCount, 1).Value & "-" & sh.Cells(RowCount, 8).Value
                .BodyFormat = 2
                .HTMLBody = "Hello "
                '.Display
                '.Save
                '.Close
                .Send
                'MsgBox "Mail saved for" & sh.Cells(RowCount, 7).Value & "!"
                RowCount = RowCount + 1
        End With

    Loop

    Set outlookMail = Nothing
    Set outlookApp = Nothing
    MsgBox "All mails sent!"

End Sub

Answer 1

不确定您想要优化哪些部分，但在查看您的示例后，我会考虑改变一些事项;

循环中唯一变化的东西是收件人和主题行，正文总是相同的（显然我不知道这些单元格中存储了什么）但是也许你可以构建收件人如果你用分号分隔电子邮件地址并发送一封电子邮件而不是多封电子邮件，循环中的字符串应该可以正常工作吗？

我要提到的另一件事是，当你遇到一个空行时你就停止了，这意味着如果有人错误地删除了该行，那么循环可能无法接收所有收件人。有许多更健壮的方法可以找到您可以使用的数据的结尾。

希望有所帮助。

Answer 2

您无需创建 Outlook Object twice 。 Set outlookApp = CreateObject("Outlook.Application") 并将 Dim RowCount As Integer 更改为 Dim RowCount As Long

Also avoid .Activate

Option Explicit
Sub EmailToAll()
    Dim outlookApp As Outlook.Application
    Dim outlookMail As Outlook.MailItem
    Dim RowCount As Long

    Set outlookApp = CreateObject("Outlook.Application")

    RowCount = 2

    With Worksheets("Final_List")
        Do While IsEmpty(Cells(RowCount, 1).Value) = False

            Set outlookMail = outlookApp.CreateItem(olMailItem)
            With outlookMail
                    .To = Cells(RowCount, 7).Value
                    .CC = Cells(RowCount, 9).Value
                    .BCC = Empty
                    .Subject = "[Update]" & " " & Cells(RowCount, 1).Value & "-" & Cells(RowCount, 8).Value
                    .BodyFormat = 2
                    .HTMLBody = "Hello "
                    .Send
            End With
            RowCount = RowCount + 1
        Loop
    End With

    Set outlookMail = Nothing
    Set outlookApp = Nothing

    MsgBox "All mails sent!"

End Sub

Excel使用Excel工作表中的特定字段自动化Outlook中的电子邮件

2 个答案: