エクセルVBAでメール送信する方法の改造方法を教えてください

このQ&Aのポイント
  • VBA初心者です。エクセルのデータをメール送信したく、ネットで検索して希望に近いVBAを見付けたのですが改造の仕方が分からず、どのように記述したらいいのか教えてください。
  • シート1の担当者の名前列にメールアドレスが入っている場合に、その行だけメールを送信したいです。また、シート2のA7セルにメール件名、A10から本文が記述されています。
  • 現在はA列しか送信されず、他の情報も本文に含めたいです。シート1のD列に商品、E列に購入日付を入れて、A列とD列とE列に記されている内容をメール本文に載せたいです。具体的な記述方法を教えてください。
回答を見る
  • ベストアンサー

エクセルVABの変更の仕方

VBA初心者です。 エクセルのデータをメール送信したく、ネットで検索して希望に近いVBAを見付けたのですが改造の仕方が分からず、どのように記述したらいいのか教えてください。 シート1『宛先マスタ』のA列に担当者の名前が入ってます。 B列にメールアドレス C列に『1』を入れたところだけメール送信 シート2『送信文章』のA7セルにメール件名 A10から本文 となってます。 現状のままだとA列が入らず、他にも入れたいことがあるので シート1『宛先マスタ』の D列に商品 E列に購入日付 を入れて、A・D・Eに明記されている内容をメール本文に載せたいのですが、どのように記述したらよいのでしょうか? 以下、現状のプログラムの一部です。 ********* '作成開始の確認 If MsgBox("メールを作成します、よろしいですか?", vbYesNo, "確認") = vbNo Then Exit Sub 'vbNo いいえ だったら、関数をすぐに抜ける。 End If '件名に 送信文章シートのA7の件名をセットする Dim strTITLE As String 'メールの件名、タイトル。 strTITLE = Trim(Sheets("送信文章").Range("A7")) '隣の送信文章のA7セルを代入 '本文は、送信文章シートのA10から ”↑ここまで” を つなげ、セットする。 Dim strDOC As String '送信する文章 Dim strWORK As String '一時変数 Dim yLINE As Integer 'Y行目のカウント '本文を作る strDOC = "" '初期化する For yLINE = 10 To 999 '10行目から最大999行まで strWORK = Sheets("送信文章").Cells(yLINE, "A") 'A列のY行目の文字を取り出す If strWORK = "↑ここまで" Then Exit For '↑ここまで だったら ループを抜ける strDOC = strDOC & strWORK & vbCrLf '1行、文字を追加する Next yLINE Debug.Print "作られた本文は:[" & strDOC & "]です。" & vbCrLf & vbCrLf ' Outlook を 起動 Dim oApp As Object 'OutlookのApplication オブジェクトを入れる Dim myNameSpace As Object '名前のスペースと言われても、、 Dim myFolder As Object 'フォルダー指定 'outlook 起動をCreateObjectで ※これだと複数起動してしまうがご勘弁を Set oApp = CreateObject("Outlook.Application") ****** 『本文は、送信文章シート…』からの辺りに記述すればいいのかなと参考書を調べたりしたのですがサッパリ分からず…。 VBAに詳しい方、教えていただけると大変助かります。

質問者が選んだベストアンサー

  • ベストアンサー
  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.1

手順の組み立ては次のとおりになります。 1.マスタシートのA列の上から下までのセルをFor Next巡回する 2.各セルのC列が1でなかったらスルーする、1なら次の作業を行う 3.各列のADE列のセルの内容を、雛形シートの所定のセルに転記する 4.拾ったマクロでアドレス設定、メールの本文整形、Outlookで送出まで行う 5.1に戻って繰り返す。 サンプル: sub Macro1() dim h as range ’1 for each h in worksheets("宛先マスタ").range("A2:A" & worksheets("宛先マスタ").range("A65536").end(xlup).row) ’2 if h.offset(0, 2) = 1 then ’3 worksheets("送信文章").range("A17") = h worksheets("送信文章").range("A18") = h.offset(0, 3) worksheets("送信文章").range("A19") = h.offset(0, 4) ’4  アドレスのセット(掲示されていない)  メール件名のセット  メール本文の生成と送出 ’5 End If Next End Sub

beru2007
質問者

補足

早々の回答ありがとうございます。 http://outlook.vba-ken3.jp/sample/001/2009-05-11.html すみません、こちらのサイト様のサンプルファイルなのですが回答頂いたプログラムはどこに記述したらよいのでしょう? 一応上の方に記述してみたのですがエラーが出てしまいまして…。 どうしたらいいのかサッパリ分からないので再度教えていただけるとありがたいです。m(_)m

関連するQ&A

  • Outlookのメールを送信するマクロ

    お世話になっております。 Microsoft Outlook2003使用で メール送信のマクロを見様見真似で作ってみたのですが、本文部分がうまくいきません(Best regardsしか表示されません)。 どうすれば正しく反映されるでしょうか? シートのB1にToアドレスを記入していてTo_addressと名前付 以下、Cc_addressとSubjectも同様にしています。 本文の文章は何行かあり、途中で空白行も入れたいのですが、そこまでまだ手がつけられていません。 本文の文章が3行あるとすると、このマクロではComment1、Comment2、Comment3と名前付しています。 Sub SendEmail() Dim OlApp As Outlook.Application Dim mItem As Outlook.MailItem Dim cell As Range Dim Subj As String Dim EmailAddr As String Dim Recipient As String Dim Msg As String Dim Message As String Dim Sender As String Dim Comments As String Dim Comments2 As String Dim report As String Worksheets("Sheet1").Activate 'Create Outlook object  Set OutlookApp = New Outlook.Application 'Get the data Subj = Range("Subject") EmailAddr = Range("To_address") CCAddr = Range("Cc_address") Body = Range("Comment1") & ("Comment2") & ("Comment3") 'Compose message Msg = Msg & Comment1 & vbCrLf & vbCrLf Msg = Msg & Comment2 & vbCrLf & vbCrLf Msg = Msg & "Best regards," & vbCrLf & vbCrLf 'Create Mail Item Set mItem = OutlookApp.CreateItem(olMailItem) With mItem .To = EmailAddr .CC = CCAddr .BCC = BCCAddr .Subject = Subj .Body = Msg .Display End With End Sub 宜しくお願い致します。

  • エクセルでOutlookのメールを作成

    エクセルでOutlookのメールを作成しようとしています。 一応、以下のコードでできるようです。 質問は、メール本文中の ABC という文字だけを赤い太字にする方法です。教えてください。 Sub test01() Dim mi As Object ' MailItem Dim wdDoc As Object ' Word.Document Dim olApp As Object ' Outlook.Application Set olApp = CreateObject("Outlook.Application") Set mi = olApp.CreateItem(0) mi.To = "test@abc.co.jp" ' 送り先 mi.BodyFormat = 2 ' メールを HTML 形式にする mi.Display ' メールを表示する Set wdDoc = olApp.ActiveInspector.WordEditor ' メールの Word エディタを取得する wdDoc.Windows(1).Document.Range.Text = "本文本文本文本文本文1" _ & vbCrLf & "本文本文本文本文本文2" _ & vbCrLf & "本文ABC本文本文3" With wdDoc.Windows(1).Document.Range.Font .Name = "Meiryo UI" ' メール本文のフォントを "Meiryo UI" .Size = 11 ' フォントサイズを 11 に設定する End With End Sub

  • エクセルマクロ メール作成

    お世話になります。 メールの定期配信業務があり、簡略化のためマクロ作成しております。 WSHを使った構文を見つけましたので、以下のような構文を作りました。 <エクセルシート> 横に【宛先1(to)】【宛先2(cc)】【件名】【本文】【添付ファイルパス】 の順に並んでおり、列方向にはリストとなっています。 <Module> Sub メール書き込み() Dim 宛先1 As String Dim 件名 As String Dim 本文 As String Dim 添付 As String Dim 宛先2 As String Dim 行 As Long, 行下端 As Long Dim sComd As String 行下端 = Range("B65536").End(xlUp).Row 行 = 2 Do While 行 <= 行下端 宛先1 = Cells(行, 1).Text 宛先2 = Cells(行, 2).Text 件名 = Cells(行, 3).Text 本文 = Cells(行, 4).Value 添付 = Cells(行, 5).Text sComd = "Mailto:" & 宛先1 & "?Subject=" & 件名 & "&body=" & 本文 Debug.Print sComd CreateObject("WScript.Shell").Run sComd 行 = 行 + 1 Loop End Sub この状態で、複数メールを作成することはできましたが、不満点があり、御教示願いたく考えております。 mailto 以下の書き方が分からず困っているのが以下の点です。 1、CC(宛先2)を追加したい。 2、添付を追加したい。 また、本文の改行も反映できるようにしたいのですが、これは可能でしょうか? 複数件質問になってしまい恐縮ですが、よろしくお願い致します。

  • EXCEL VBA メール送信でファイル添付

    現在、使用しているVBAを利用したメンバー向け案内メール配信で、ファイルを添付できないかと考えております。 G列に入力したアドレスのファイルを添付して送信できればと思うのですが、ご教授願えませんでしょうか。 現在のVBAは企業名、宛先共に変えられるように下記のような形となっております。 添付ファイルも宛先毎に異なります。 B列:送信先メールアドレス C列:メール件名 D列:送信先所属名 E列:送信先宛名 F列:メール本文 コマンドボタンで一括配信となっております。 【以下記述】 Sub Mail_Send() 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/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Worksheets("Sheet1").Range("C2").Value .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Worksheets("Sheet1").Range("C3").Value .Update End With ' 送信範囲設定 LastRow = Worksheets("Sheet1").Range("B7").End(xlDown).Row ' メール送信ループ For i = 8 To LastRow ' 送信状況メッセージクリア Worksheets("Sheet1").Range("F2").Value = "" ' メール本文作成 strbody = Worksheets("Sheet1").Range("D" & i).Value & vbCrLf & " " & _ Worksheets("Sheet1").Range("E" & i).Value & " 様" & vbCrLf & vbCrLf & _ Worksheets("Sheet1").Range("F" & i).Value ' 改行変換(送信環境によってはここの修正が必要かも) tmpstrbody = Replace(strbody, vbLf, vbCrLf) strbody = Replace(tmpstrbody, vbCr & vbCrLf, vbCrLf) ' メール送信 With iMsg Set .Configuration = iConf .From = Worksheets("Sheet1").Range("C4").Value .To = Worksheets("Sheet1").Range("B" & i).Value .BCC = Worksheets("Sheet1").Range("C5").Value .Subject = Worksheets("Sheet1").Range("C" & i).Value .TextBody = strbody .Send End With ' 送信状況メッセージ更新 Worksheets("Sheet1").Range("F2").Value = Worksheets("Sheet1").Range("B" & i).Value & " まで送信成功!" ' 3秒停止 Application.Wait [ NOW() + "0:00:03" ] Next i End Sub

  • エクセルからOUTLOOKでメール送信:2

    ●前回下記の質問を書かせていただきました。 ---------- エクセルに複数件のデータを記載してあります。 A列 に メールアドレス B列 に 件名 C列 に 本文A D列 に 本文B があるときに連続してメールを立ち上げ送信したいです。 いろいろ試してみましたが全く動きませんでした。 お手隙の際にでもお教え下さい。 マクロのサンプルソースがあると助かります。 よろしくお願いいたします。 ---------------- ●下記の回答をいただきメールの送信までは出来ました。 ---------------- Sub ボタン1_Click() Dim myOLApp As Object ' Dim myDATA As MailItem '### OUTLOOKのオブジェクトを作成後、メールを新規作成する。 Set myOLApp = CreateObject("Outlook.Application") For i=2 To 5 Set myDATA = myOLApp.CreateItem(olMailItem) '### メールの宛先、題名、本文、添付ファイルを設定する。 '(宛先のアドレス) myDATA.to = Range("A" & i).Value ' myDATA.CC = Range("D33").Value myDATA.Subject = Range("B" & i).Value myDATA.Body = Range("C" & i).Value & CHAR(10) & Range("D" & i).Value '### メールを送信 myDATA.Send Next '### お約束の後始末。 Set myDATA = Nothing Set myOLApp = Nothing End Sub こんな感じでしょうか。 For i=2 To 5 と 2行目から5行目です。 うまくいくようでしたら For i=2 To Range("A" &Rows.Count).End(xlUp).Row とでも変更してください。 なんといっても失敗すると大変なリスクが発生するプログラムです。 十分に実験してから運用してください。 ------------------------ ●メール送信は問題なくできておりましたが、  他のCSVリストよりエクセルにデータを引っ張ってきて  メールの送信を使用とした所 システムエラーです 80004005 エラーを特定できません。 と言ったエラーが出てくるようになりました。 多分他のシートから引っ張ってくる関数がジャマをしているとは思うのですが、 何かこのエラーを回避する方法はございますでしょうか? お教え下さい。

  • VBAでエクセルの文をメールに転記

    当方エクセル2016使用しています。 エクセルのVBAで、outlookのメールを自動作成したいです。 エクセルの E2に宛先 E3に件名 E4~E6に本文が入っており、 下記VBAでoutlookに各データが入る様にはできました。 しかしエクセルでは文字のサイズや色が異なっているものが、 outlook本文に反映されません。 (1行単位だったり、文字単位だったりでサイズや色が異なる) エクセルに表示されているそのままを outlook本文に表示させるにはどうしたら良いでしょうか。 ******************************** Sub Macro1() Dim toaddress As String Dim subject As String Dim mailbody As String Dim outlookObj As outlook.Application Dim mailItemObj As outlook.mailItem toaddress = Range("E2").Value subject = Range("E3").Value mailbody = Range("E4").Value mailbody = mailbody & vbCrLf & Range("E5").Value mailbody = mailbody & vbCrLf & Range("E6").Value Set outlookObj = CreateObject("Outlook.Application") Set mailItemObj = outlookObj.CreateItem(olMailItem) mailItemObj.BodyFormat = olFormatHTML mailItemObj.To = toaddress mailItemObj.subject = subject mailItemObj.body = mailbody mailItemObj.display Set outlookObj = Nothing Set mailItemObj = Nothing End Sub

  • 本文が最後に表示されてしまいます。

    以下内容でVBAを組んで、メールにコピペさせたんですが 本文が下に行き、コピーしたグラフが先に表示されます。 どうにか、  "お疲れ様です。" & vbCrLf _ & "このメールと同時にプリンターに同様の用紙が印刷されます。" & vbCrLf _ & "印刷された用紙で、前確FAXを送信してください。" &vbCrLf _ & "尚、以下内容で、前確FAX送信いたします。" の部分を本文のトップに持って来れないでしょうか? VBAは下記のように書いております。 Sub Outlookforexcel() '※1 Dim oApp As Object Dim myNameSpace As Object Dim myFolder As Object Dim objMAIL As Object 'メールのオブジェクト Dim strMOJI As String '本文 'outlook 起動 Set oApp = CreateObject("Outlook.Application") Set myNameSpace = oApp.GetNamespace("MAPI") Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダーを指定 'メールアイテムの作成 Set objMAIL = oApp.CreateItem(0) 'olMailItem=0 直値はいけないと思いつつ、 objMAIL.BodyFormat = 3 'olFormatRichText=3 で リッチテキスト形式へ '宛先・件名・本文 などのデータを代入する objMAIL.To = Range("O1") '宛先 .TO セルO3から代入 objMAIL.Cc = Range("O2") objMAIL.Subject = "【確認FAX】印刷終了以下内容で送信します。" '.Subjectで件名 strMOJI = "お疲れ様です。" & vbCrLf _ & "このメールと同時にプリンターに同様の用紙が印刷されます。" & vbCrLf _ & "印刷された用紙で、確認FAXを送信してください。" & vbCrLf _ & "尚、以下内容で、確認FAX送信いたします。" DoEvents objMAIL.Body = strMOJI '本文の初期化 DoEvents objMAIL.Display '画面表示(Mail入力、編集画面を表示) DoEvents 'Outlook貼り付けのコマンドをコマンドバーから探す Dim oCBs As Object Dim oCtl As Object '今起動中のobjMAIL(メール作成中)のコマンドバーを取り出すよ Set oCBs = objMAIL.GetInspector.CommandBars 'ループで貼り付けの文字を探す、、、 Dim I As Long 'カウンター For I = 1 To 35000 'コントロール I 番目を取り出す Set oCtl = oCBs.FindControl(, I) If Not (oCtl Is Nothing) Then 'オブジェクトが空じゃなければ '文字列でコマンド名を比較する Debug.Print ".Caption " & oCtl.Caption If oCtl.Caption = "貼り付け(&P)" Then ' ↑で見つけたら oCtlはそのままで、ループを抜ける。 Exit For 'これ以上はループしないでいいので。 End If End If Next 'コピー(Excelから)と貼り付け(Outlookへ)処理 Range("A1:I80").Select 'Excel Selection.Copy DoEvents oCtl.Execute '↑で見つけたoCtl 貼り付けコマンド(outlook)を実行 DoEvents objMAIL.send '送信箱へ ※セキュリティの警告メッセージが出るよ 'ここで、普通はオブジェクトの開放など、後始末をする。 Set oCtl = Nothing Set oCBs = Nothing End Sub

  • Excel VBA basp21でメール送信エラー

    メール送信エラーとなってしまいます。 ”Cant connect Server 11004” 同アカウントでメーラーからの送受信は成功しております。 原因はSMTP設定の関係だと思うのですが、どのようにコードを書き足せば良いのでしょうか。 また参照設定は完了しています。 ご存知のかたご回答をよろしくお願いします。 コードは以下です。 Private Sub cmd送信_Click() Dim bobj As Object Dim svname As String Dim id As String Dim pass As String Dim msg As Variant '送信チェック用 Dim strMLadr As String Dim strDPadr As String Dim strPW As String 'SMTPサーバ名:ポート番号:タイムアウト秒 svname = "サーバー:587:60" 'ログインID id = "" 'パスワード pass = "" 'オブジェクトを作成 Set bobj = CreateObject("basp21") '宛先 mailto = "" '送信者 strMLadr = "" '(送信者のメールアドレス' strDPadr = "テスト" '(送信者の表示文字列) strPW = "" '(送信者メールアドレスのパスワード) mailfrom = strDPadr & "<" & strMLadr & ">" & vbTab & id & ":" & strPW '件名 subj = "送信テスト" '本文 改行はvbCrLf body = "おはようございます。" & vbCrLf & "今日は良い天気ですね。" 'メール送信 msg = bobj.SendMail(svname, mailto, mailfrom, subj, body, "") ' 送信チェック If msg <> "" Then MsgBox "送信できませんでした。" & vbCrLf & msg, vbOKOnly + vbCritical, "エラー" Else MsgBox "送信に成功しました。", vbOKOnly + vbInformation, "完了" End If End Sub

  • VB.NETでフリーメールアドレスにメール送信できない

    VisualStudio2005で開発をしています。 SmtpClientクラスを使ってメールを自動送信するアプリを作成中なのですが、 社内サーバー同士でのメール送信は問題ないのですが、社外のメールサーバーのアドレスを指定した場合に、メールが送信されなくて困っています。 ○例:)yyyyyy@xxxxxx.co.jp → zzzzzz@xxxxxx.co.jp ×例:)yyyyyy@xxxxxx.co.jp → zzzzzz@zzzzz.com 調べてはみたのですが、原因を特定することができなかったので質問させていただきました。 1.googleやyahooなどのメールサーバーに対してでもメール送信できるようにしたいのですが、どの様にすればいいでしょうか? 2.上記のように書きましたが、本当はメールサーバまでは送信されていて、クライアントが受け取れていないという可能性もあるのでしょうか? 皆様のお力を借りたく思います。 どうかよろしくお願いいたします。 ↓↓↓以下、現在作成中のソースコード↓↓↓ Private Sub btn_Send_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btn_Send.Click '送信者 Dim senderMail As String = "xxxxx@yyyyy.co.jp" ''宛先 Dim recipientMail As String = "xxxxx@yyyyy.com" '件名 Dim subject As String = "タイトル" '本文 Dim body As String = "本文1行目" + vbCrLf + vbCrLf + "本文3行目" Dim sc As New System.Net.Mail.SmtpClient() ' メールメッセージインスタンスの生成 Dim objMessage As New System.Net.Mail.MailMessage(senderMail, recipientMail, subject, body) 'SMTPサーバーを指定する sc.Host = "mail.yyyyy.co.jp" sc.Port = 25 'メールを送信する sc.Send(objMessage) End Sub

  • エクセルでメール作成

    WIN2000 OfficeXpです。 エクセルのマクロを使って、マイクロソフトアウトルックのメールを作成したいのですが、 あるシートの  A1 を件名に  A2:D2 の範囲を本文に貼り付けるマクロはありますか? 宛先入力、送信は手動でできるように設定したいのですが。 よろしくお願いします。

専門家に質問してみよう