Sub 批量发送邮件()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim recipient As String
    Dim subject As String
    Dim body As String

    Set ws = ThisWorkbook.Sheets("Sheet1") '设置实际工作表名称

    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    On Error Resume Next
    Set OutlookApp = GetObject(class:="Outlook.Application")
    If OutlookApp Is Nothing Then
        Set OutlookApp = CreateObject(class:="Outlook.Application")
    End If
    On Error GoTo 0

    For i = 2 To lastRow
        recipient = ws.Cells(i, 1).Value
        subject = ws.Cells(i, 2).Value
        body = ws.Cells(i, 3).Value

        Set OutlookMail = OutlookApp.CreateItem(0)

        With OutlookMail
            .To = recipient '邮箱地址
            .subject = subject '邮件主题
            .body = body '邮件正文
            .Send
        End With

        Set OutlookMail = Nothing
    Next i

    Set OutlookApp = Nothing

    MsgBox "邮件批量发送成功!", vbInformation, "逗号技巧"
End Sub