VBA メール一斉送信で添付ファイルを送れるようにするとエラー

VBAは全く分からず、現在使用しているのは、調べたものをそのままコピーして今の形式に合うようにシート名やらセル名を入替えて使っているものです。
色々調べて、添付できるように .addattachment Range("G8")　と　 Set iMsg = Nothing　を追加したところ、一人目には問題なく送信できたんですが、2人目からエラーになります。

●実行エラー‘91‘：オブジェクト変数またはWithブロック変数が設定されていません。
デバッグすると、 Set .Configuration = iConf　が黄色くハイライトされます。

他の方の一斉送信を見てみると、これで動作している方もいるようなので、どこをどうしていいのか全く分からず途方にくれています。

これができないと、手動でひとりずつメールに添付するか、一斉送信の生きてる1行目にひとりずつコピペして送信するという恐ろしい作業になってしまいます。
どなたか、お詳しい方、お助け下さいm(_ _)m

以下、宜しくお願い致します。

シート名　イレギュラーメール
B8～　送信先メアド
C8～　メール件名
D8～　送信先団体名
E8～　送信先宛名
F8～　メール本文
G8～　添付ファイル


Sub イレギュラーメール()
'
' イレギュラーメール Macro
'
' 変数設定
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
Dim i, LastRow As Integer

' CDOオブジェクト初期設定
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/s … = 2
.Item("http://schemas.microsoft.com/cdo/configuration/s … = Worksheets("イレギュラー").Range("C2").Value
.Item("http://schemas.microsoft.com/cdo/configuration/s … = Worksheets("イレギュラー").Range("C3").Value
' .Item("http://schemas.microsoft.com/cdo/configuration/s … = 1
' .Item("http://schemas.microsoft.com/cdo/configuration/s … = "あなたのユーザーID"
' .Item("http://schemas.microsoft.com/cdo/configuration/s … = "あなたのパスワード"
.Update
End With


' 送信範囲設定
LastRow = Worksheets("イレギュラー").Range("B7").End(xlDown).Row

' メール送信ループ
For i = 8 To LastRow

' 送信状況メッセージクリア
Worksheets("イレギュラー").Range("F2").Value = ""


' メール本文作成
strbody = Worksheets("イレギュラー").Range("D" & i).Value & vbCrLf & "　" & _
Worksheets("イレギュラー").Range("E" & i).Value & "　様" & vbCrLf & vbCrLf & _
Worksheets("イレギュラー").Range("F" & i).Value

' 改行変換
tmpstrbody = Replace(strbody, vbLf, vbCrLf)
strbody = Replace(tmpstrbody, vbCr & vbCrLf, vbCrLf)

' メール送信
With iMsg
Set .Configuration = iConf
.From = Worksheets("イレギュラー").Range("C4").Value
.To = Worksheets("イレギュラー").Range("B" & i).Value
.BCC = Worksheets("イレギュラー").Range("C5").Value
.Subject = Worksheets("イレギュラー").Range("C" & i).Value
.TextBody = strbody
.addattachment Range("G8")
.Send
End With

' 送信状況メッセージ更新
Worksheets("イレギュラー").Range("F2").Value = Worksheets("イレギュラー").Range("B" & i).Value & " まで送信成功！"

' ３秒停止
Application.Wait [ NOW() + "0:00:03" ]
Set iMsg = Nothing

Next i

End Sub

No.1 ベストアンサー 回答者： bonaron 回答日時： 2016/09/28 11:18

> Application.Wait [ NOW() + "0:00:03" ]

> Set iMsg = Nothing
>
> Next i

ループの中でこれはまずいでしょ。
Set iMsg = Nothing

この回答へのお礼

ちゃんとエラーなく動作しました！！
早速にお教え頂いて、ありがとうございます！！
助かりました！
素人で全然分からず、非常に困っていたので、感謝しております。
ありがとうございます。m(_ _)m

お礼日時：2016/09/28 16:56