Excelで一斉メール送信ソフトを作ってみよう

Private Sub ExAllSendMail(lrow As Long)
    Dim sret As String
    Dim szServer As String  'SMTPサーバー名
    Dim szFrom As String    '送信元
    Dim szTo As String      '宛先
    Dim szSubject As String '件名
    Dim szBody As String    '本文
    Dim szFile As String    '添付ファイル
    Dim i As Long
    
    szServer = Range("J7") & ":" & Range("M7")
    If Range("J6") = "" Then
        szFrom = Range("JI8")
    Else
        szFrom = Range("J6") & "<" & Range("J8") & ">"
    End If
    szSubject = Range("J10")
    szBody = Range("J11")
    szFile = ""
    
On Error GoTo ErrEnd
    For i = 7 To lrow
        '送信マークとアドレスの確認
        If Cells(i, 2) = 1 And Cells(i, 4) <> "" Then
            Cells(i, 5) = ""
            Cells(i, 6) = "送信中！！"
            Cells(i, 6).Font.Color = RGB(255, 0, 0)
            
            '宛名
            If Cells(i, 3) = "" Then
                szTo = Cells(i, 3)
            Else
                szTo = Cells(i, 3) & "<" & Cells(i, 4) & ">"
            End If
        
            sret = SendMail(szServer, szTo, szFrom, szSubject, szBody, szFile)

            Cells(i, 6).Font.Color = RGB(0, 0, 0)
            '送信エラーの場合
            If Len(sret) <> 0 Then
                Cells(i, 5) = "Error"
                Cells(i, 6) = sret
            Else
                Cells(i, 5) = Format(Now, "yyyy/mm/dd hh:nn:ss")
                Cells(i, 6) = ""
            End If
        End If
    Next
    Exit Sub
ErrEnd:
    Range("E2") = ""
MsgBox "送信中にエラーが発生しました。処理を中止します。" _
& vbCrLf & Err.Description, , "一斉メール送信"

End Sub

下記のVBAコードに変更してください。

Private Sub CommandButton2_Click()
    Dim lrow As Long
    
    '送信設定値のチェック
    If ExDataCheck = False Then
        Exit Sub
    End If
    '送信先アドレスの最終行を調べる
    lrow = ActiveSheet.Range("D65536").End(xlUp).Row
    If lrow = 6 Then
        MsgBox "送信先アドレスは最低１件は入力してください。", , "一斉メール送信"
    End If
    '一斉メール送信
    ExAllSendMail lrow
End Sub