皆さん、いつもありがとうございます。
下から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.1
- 回答日時:
昨日まで問題なかったものが急に動かなくなったのでしょうか?
どこかを追加・変更したのではありませんか。
>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も確認しましたが動きませんでした。
勉強になりました。
No.2ベストアンサー
- 回答日時:
こんにちは
セルに書いてある 添付ファイルのパスは合っていますか?
又、ファイルは存在していますか?(ファイル名変えてませんか)
objMail.Attachments.Add 前にファイルの存在を確認しては?
例えば、
If ActiveCell.Offset(i, 9).Value <> "" Then
If Not Dir(asrs1) <> "" Then
objMail.Attachments.Add asrs1
End If
End If
しかし、ループ内での処理だと困るか・・
出来れば、事前にデータを取得、チェック 実行
必要データを取得してデータで処理をするように書き換えるのが良いと思いますが、だいぶ変わってしまいますね
Qchan1962様
こんばんは。
今回は長い構文ですので印刷して競べながら勉強します。
いつも利用する人に考えた細かなご配慮ありがとうございます。
また二回もご連絡いただき感謝申し上げます。
No.3
- 回答日時:
#2 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
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) VBAでoutlook365が起動しません。 4 2022/08/25 13:31
- Visual Basic(VBA) 稀に1円合いません? Sheet1から金額と個数を貼り付ける下記コードで、金額を切り上げるコードを何 3 2022/09/05 15:11
- Visual Basic(VBA) オブジェクトが見つかりません 1 2023/06/24 19:43
- Excel(エクセル) VBAの指示の内容 昨日こちらでご教示頂いたのですが初心者な為、一つ一つの指示が何をやっているのかわ 2 2022/10/25 18:08
- Visual Basic(VBA) エクセルのマクロを使ってメールを送る方法について教えてください 2 2022/03/29 01:36
- Visual Basic(VBA) 別シートのデータを参照して値を入れたい。 まとめデータシートのC列D列の値を商品一覧シートのコードが 7 2022/08/17 13:20
- Visual Basic(VBA) VBA処理追加 こちらでご教示頂いたのですが回答完了させてしまいましたのでこちらからまた質問させてく 2 2022/10/27 09:57
- Visual Basic(VBA) VBAのユーザーフォームのテキストボックスに入力制限をしたい 6 2022/11/15 08:28
- Visual Basic(VBA) Excelで下記のようにマクロを作ったところ、一回目は実行できたのですが、二回目以降「実行時エラー1 1 2022/03/25 08:08
- Visual Basic(VBA) エラーコード1004 6 2022/06/09 14:12
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
既婚で現役のAV女優さんは居ま...
-
VBA ソートすると、1、11、...
-
相対参照から絶対参照に変換す...
-
別ブックの空白行に転記
-
ExcelVBAで指定文字(この場合...
-
CDレコの曲の消し方を教えてく...
-
YmobileからSoftbankに乗り換え...
-
射精したあとの匂いって他人に...
-
精液のにおいがほとんど無いの...
-
おっぱいを舐める
-
夫にセックスがないのなら他人...
-
1日3回セックスって多いですか...
-
彼女をオカズにして抜くのって...
-
先日彼氏とラブホに行ったら電...
-
彼とのエッチで、彼がイクのが...
-
男の精子ってどんな匂いですか、
-
手マンしたあと それとなく指の...
-
手マンした手って臭いですか?
-
手マンしたあと彼氏の指に私の...
-
彼氏の精液の匂いが無味無臭(...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
既婚で現役のAV女優さんは居ま...
-
VBA ソートすると、1、11、...
-
CDレコの曲の消し方を教えてく...
-
VBAが止まります。
-
EXCELで3行を一組にして結合す...
-
大昔から、クンニ、フェラって...
-
シンナーの夏型と冬型の違いは?
-
私は今年で60歳で孤独です。40...
-
別ブックの空白行に転記
-
女性が頼まれなくてもフェラす...
-
直線コネクタの中央にコネクタ...
-
エクセル最終行の下に貼り付け
-
相対参照から絶対参照に変換す...
-
データの平均を1分値にまとめる...
-
Word 黒塗り部分の文字のみ削除...
-
4次元について
-
ウォークマンa30についてです。...
-
Excelで抽出・連続印刷したいです
-
最適な組み合わせの自動計算
-
ExcelVBAで指定文字(この場合...
おすすめ情報