VBAが止まります。

皆さん、いつもありがとうございます。
下から14行目の『 objMail.Attachments.Add asrs1』で止まってしまします。
asrs1をadrs1へ修正したりしましたが、改善されません。
昨日まで動いたいたのですが。
皆様、修正方法を教えていただけますでしdょうか。

-------------------------------------------------------
Sub メール作成()
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim wsMail As Worksheet
Dim filead As String
Dim tenp1 As String
Dim tenp2 As String

'メール立ち上げ
Set objOutlook = New Outlook.Application
Set wsMail = ThisWorkbook.Sheets("リスト")

'添付ファイルのアドレスを変数にする
filead = Worksheets("リスト").Range("B3").Value

'共通添付データのアドレスを読む
tenp1 = filead & "\" & Worksheets("リスト").Range("B4")
tenp2 = filead & "\" & Worksheets("リスト").Range("B5")

Dim kobetsumail1 As String
Dim kobetsumail2 As String
Dim adrs1 As String
Dim asrs2 As String

'変数iを設定。最初は1
Dim i As Long
i = 1

'送付前の確認メッセージ
Dim rc As Long
rc = MsgBox("記載に誤りが無いことを確認しましたか？", vbYesNo + vbQuestion, "確認")

If rc = vbNo Then
MsgBox "中断しました"
End
End If

'基準となるセルを選択
Worksheets("リスト").Select
Range("B7").Select

'取引先名が書かれているB列が空欄になるまで続ける
Do Until ActiveCell.Offset(i, 0).Value = ""

'送付チェック欄が○なら作業を続ける
If ActiveCell.Offset(i, 2).Value = "○" Then

Set objMail = objOutlook.CreateItem(olMailTtem)

'個別メールのデータ名称を読む
Dim CC12(1) As String
CC12(0) = ActiveCell.Offset(i, 6).Value
CC12(1) = ActiveCell.Offset(i, 8).Value

'メールを作成する
With wsMail
objMail.to = ActiveCell.Offset(i, 4).Value
objMail.CC = Join(CC12, ";")
objMail.Subject = Range("B1").Value
objMail.Bodyformat = olFormatPlain
objMail.body = Range("B7").Offset(i, 0) & vbCrLf & Range("E7").Offset(i, 0) & "様" & vbCrLf & vbCrLf & Range("B2").Value & vbCrLf & vbCrLf

kobetsumail1 = ActiveCell.Offset(i, 9).Value
asrs1 = filead & "\" & kobetsumail1

kobetsumail2 = ActiveCell.Offset(i, 10).Value
asrs2 = filead & "\" & kobetsumail2

If Range("B4").Value <> "" Then
objMail.Attachments.Add tenp1
End If

If Range("B5").Value <> "" Then
objMail.Attachments.Add tenp2
End If

If ActiveCell.Offset(i, 9).Value <> "" Then
objMail.Attachments.Add asrs1
End If

If ActiveCell.Offset(i, 10).Value <> "" Then
objMail.Attachments.Add asrs2
End If

objMail.Display
objMail.Save

End With

End If

i = i + 1

Loop

Set objOutlook = Nothing

MsgBox "下書きに保管しました"
End Sub

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2022/08/31 17:31

こんにちは

セルに書いてある　添付ファイルのパスは合っていますか？
又、ファイルは存在していますか？（ファイル名変えてませんか）
objMail.Attachments.Add　前にファイルの存在を確認しては？
例えば、
If ActiveCell.Offset(i, 9).Value <> "" Then
If Not Dir(asrs1) <> "" Then
objMail.Attachments.Add asrs1
End If
End If
しかし、ループ内での処理だと困るか・・
出来れば、事前にデータを取得、チェック　実行　
必要データを取得してデータで処理をするように書き換えるのが良いと思いますが、だいぶ変わってしまいますね

この回答へのお礼

Qchan1962様
こんばんは。
今回は長い構文ですので印刷して競べながら勉強します。

いつも利用する人に考えた細かなご配慮ありがとうございます。
また二回もご連絡いただき感謝申し上げます。

お礼日時：2022/08/31 19:51

No.3 回答者： Qchan1962 回答日時： 2022/08/31 18:03

＃２　If Not Dir(asrs1) <> "" Then　すみません　Notでは無いですね

ちょっとチェックする部分を追加して書いて見ましたが、どうでしょう
2度手間のようになっていますが、現行コードを出来るだけ使い、分けてみました　未検証ですので上手くいかない場合は修正してください
（文字数の関係で制御系、解放処理は割愛・・追加してください）
Option Explicit

Sub メール作成()
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim filead As String
Dim atcAdrs(1)
'送付前の確認メッセージ
Dim rc As Long
rc = MsgBox("記載に誤りが無いことを確認しましたか？", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
MsgBox "中断しました"
End
End If

Dim strSubject As String
Dim strBody As String
Dim axisCell As Range
Dim strMsg As String
Dim i As Long

With ThisWorkbook.Worksheets("リスト") 'シートで変わらない値を予め変数に代入
'添付ファイルのアドレスを変数にする
filead = .Range("B3").Value
'添付データのアドレスチェック--------
For i = 4 To 5
If .Cells(i, "B").Value <> "" Then
If Not Dir(filead & "\" & .Cells(i, "B").Value) <> "" Then
strMsg = strMsg & .Cells(i, "B").Value
Else
'共通添付
atcAdrs(i - 4) = filead & "\" & .Cells(i, "B").Value
End If
End If
Next
If strMsg <> "" Then
MsgBox strMsg, , "既定添付ファイルが見つかりません"
Exit Sub '終了
End If
Dim c As Range
'個別添付ファイルの事前確認
For Each c In .Range(.Range("D7"), .Cells(.Rows.Count, "D").End(xlUp))
If c.Value = "○" Then
For i = 7 To 8
If c.Offset(, i).Value <> "" Then
If Not Dir(filead & "\" & c.Offset(, i).Value) <> "" Then
strMsg = strMsg & c.Offset(, -2).Value & "::" & filead & "\" & c.Offset(, i).Value & vbCrLf
End If
End If
Next i
End If
Next c

If strMsg <> "" Then 'NGメッセージ
MsgBox strMsg, , "個別添付ファイルが見つかりません"
Exit Sub '終了
End If

'メールデータ取得
strSubject = .Range("B1").Value
strBody = "様" & vbCrLf & vbCrLf & .Range("B2").Value & vbCrLf & vbCrLf
'基準となるセルを変数に（設定）
Set axisCell = .Range("B7")
End With 'リストシート事前チェック・既定データ取得終了


'変数を規定値に
i = 1
strMsg = ""
'Outlookメール立ち上げ
Set objOutlook = New Outlook.Application
With axisCell '基軸セルで括る
'取引先名が書かれているB列が空欄になるまで続ける
Do Until .Offset(i, 0).Value = ""
'送付チェック欄が○なら作業を続ける (注意　○には文字種あり）
If .Offset(i, 2).Value = "○" Then
'メール作成-------
Set objMail = objOutlook.CreateItem(olMailItem)
'個別メールのデータ名称を読む
Dim CC12(1) As String
CC12(0) = .Offset(i, 6).Value
CC12(1) = .Offset(i, 8).Value
'メールの各項目に入力
objMail.To = .Offset(i, 4).Value
objMail.CC = Join(CC12, ";")
objMail.Subject = strSubject
objMail.Bodyformat = olFormatPlain
'本文
objMail.body = .Offset(i, 0) & vbCrLf & .Offset(i, 3) & strBody

'共通添付
If atcAdrs(0) <> "" Then objMail.Attachments.Add atcAdrs(0)
If atcAdrs(1) <> "" Then objMail.Attachments.Add atcAdrs(1)
'個別添付
If .Offset(i, 9).Value <> "" Then objMail.Attachments.Add filead & "\" & .Offset(i, 9).Value
If .Offset(i, 10).Value <> "" Then objMail.Attachments.Add filead & "\" & .Offset(i, 10).Value

'メールアクション
objMail.Display '表示（確認して操作）
objMail.Save '保存
'objMail.Send　'送信
'処理成果メッセージの作成
strMsg = strMsg & .Offset(i, 4).Value & vbCrLf
End If
i = i + 1
Loop
End With

Set objOutlook = Nothing

If strMsg <> "" Then
MsgBox "処理リスト" & vbCrLf & strMsg, , "完了しました"
Else
MsgBox "実行しましたが、条件に一致する送り先が見つかりませんでした"
End If

End Sub

No.1 回答者： Zincer 回答日時： 2022/08/31 15:40

昨日まで問題なかったものが急に動かなくなったのでしょうか？

どこかを追加・変更したのではありませんか。

＞asrs1をadrs1へ修正したりしましたが、改善されません。
Dim adrs1 As String
Dim asrs2 As String
しか変数が定義されていないように見えますが、そこが原因ではないですか？
asrs1 = filead & "\" & kobetsumail1
も気になります。
まずは、Option Explicit ステートメントを指定して、変数を明示的に宣言することをお勧めします。
Option Explicit ステートメント
https://docs.microsoft.com/ja-jp/office/vba/lang …

この回答へのお礼

zincer様
こんばんは、回答有り難うございました。
asrs1 = filead & "\" & kobetsumail1も確認しましたが動きませんでした。
勉強になりました。

お礼日時：2022/08/31 19:46