エクセルでVBAを使用してメール送信する際に、CCに取引先のリーダーも追加したい

このQ&Aのポイント
  • エクセルでお客様のリストを作成して、VBAを使用してメールソフトでお客様に送信しています。しかし、6月からCCに取引先のリーダーも追加する必要があり困っています。
  • 現在、メールアドレスの宛先は別のシートからVLOOKUP関数を使用して表示させており、CCには直接アドレスを入力しています。しかし、部署が3つあり、内容によって部署が変わるため、部署のアドレスもVLOOKUP関数で表示させたいです。
  • 質問文章の要点は、エクセルでお客様のリストを作成し、VBAを使用してメール送信しているが、CCに取引先のリーダーを追加する必要があり困っている。また、部署によってアドレスが変わるため、VLOOKUP関数を使用してアドレスを表示させたいということです。
回答を見る
  • ベストアンサー

エクセルでこまってます。

VBAで困ってます。 エクセルでお客様のリストを作成して、メールソフトでお客様に送信しております。 6月から変更がありとても困っております。 以下内容をご確認ください。 Sub Thunderbird_VBA() Dim sPath As String Dim mailadto As String Dim mailadcc As String Dim substring As String Dim bodystring As String Dim attachPath As String sPath = """C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe"" -compose " 'さんだーバードを開く mailadto = Worksheets("納品引上メール").Range("R5").Value '宛先の設定 mailadcc = "xxx@xxx.com" & ";" & "yyy@yyy.com" & ";" & "zzz@zzz.com" 'CCの設定 substring = Worksheets("納品引上メール").Range("L9").Value '件名の設定 bodystring = Range("l13").Value Shell sPath & "to=" & mailadto & "," & "cc=" & mailadcc & "," & "subject=" & substring & "," & "body=" & bodystring & "," & "attachment=" & attachPath End Sub 上のようなものを見様見真似で作成して使っております。 6月からCCに一人追加するようになりました。 現在 mailadtoは違うシートからR5のセルにVLOOKUP関数でアドレスを表示させております。 mailadccは社内のリーダーに送るため直接アドレスを入れております。 したいこと 取引先のリーダーにもCCでメールを送信したい。 部署は3つあり内容によって部署が変わるので そのアドレスも R6のセルにVLOOKUP関数で表示させたい。 誰かお助けください。

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

  • ベストアンサー
  • kkkkkm
  • ベストアンサー率65% (1620/2459)
回答No.1

mailadcc = "xxx@xxx.com" & ";" & "yyy@yyy.com" & ";" & "zzz@zzz.com" & ";" & Worksheets("納品引上メール").Range("R6").Value でいかがですか。

naoki-kawamoto
質問者

お礼

完璧です!!

関連するQ&A

  • エクセルマクロ実行時エラー1004について

    システムを起動すると実行時エラー1004とでて5行目のWorksheets(3).Selectで止まってしまいます。 私が作成したものではなく、なぜなのかわかりません。緊急を要しています。誰かわかる方いらっしゃらないでしょうか。 よろしくお願いします。 Dim Max_data2 As Integer Public Cunt_01 As Integer Sub auto_open() Dim wkSheet As Excel.Worksheet Worksheets(3).Select ' Range("c4") = Date ' Range("c20") = Date Range("d6").Select With Worksheets("工場、受注一覧表") ' Worksheets("工場、出荷指示書").Range("j3").Value = Date ' Worksheets("工場、出荷指示書").Range("I4").Value = Date ' Worksheets("工場、出荷指示書").Range("J4").Value = Time .Range("d5").Value = Date .Range("d21").Value = Date .Range("d23").Value = Date End With For Each wkSheet In ThisWorkbook.Worksheets If InStr(wkSheet.Name, "工場、出荷指示書") <> 0 Or InStr(wkSheet.Name, "@") <> 0 Then wkSheet.Range("J3").Value = Date wkSheet.Range("I4").Value = Date wkSheet.Range("J4").Value = Time End If Next Call com_list Cunt_01 = 10 '1件づつ転記のカウンタ '★追加★ '入出庫報告書のファイルを開く Dim sPath As String sPath = ThisWorkbook.Worksheets("工場、受注一覧表").Range("W1").Value If sPath = "" Then Exit Sub End If If Dir(sPath) <> "" Then Workbooks.Open (sPath) End If ThisWorkbook.Activate ''★23.06.12 ActiveWindow.SmallScroll ToRight:=4 End Sub

  • エクセルで100以上のシートからデータを読み込むのに時間がかかり困っています

    エクセル2003でAuto_Open時にデータの更新をしてみましたが、一々画面を読んでしまい時間がかかってしまいます。 まだコードがよく理解できていませんので、どなたかよい方法を教えてください。 コードは以下のようです。 シートは180あり、一覧表にシート名の表を作りました。 よろしくお願いします。 Sub Auto_Open() 'シートオープンで一覧表のデータ更新 '変数の宣言 Dim MyDA As Integer Dim MyDB As String Dim MyDC As String Dim MyDD As String Dim MyDE As String Dim MyDF As String Dim MyDG As String Dim MyDH As String Dim MyDI As String Dim MyDJ As String Dim MyDK As String For MyDA = 3 To 173 '一覧表を呼びシート名の代入 Worksheets("一覧表").Activate MyDB = Range("T" & MyDA).Value '必要なデータの代入 Worksheets(MyDB).Activate MyDC = Range("J3").Value MyDD = Range("J4").Value MyDE = Range("B6").Value MyDF = Range("F6").Value MyDG = Range("K6").Value MyDH = Range("C9").Value MyDI = Range("B8").Value If MyDI = "" Then MyDI = "-" End If MyDJ = Range("F8").Value If MyDJ = "" Then MyDJ = "-" End If MyDK = Range("K8").Value If MyDK = "" Then MyDK = "-" End If Sheets("一覧表").Activate Range("B" & MyDA) = MyDC Range("C" & MyDA) = MyDD Range("D" & MyDA) = MyDE Range("E" & MyDA) = MyDF Range("F" & MyDA) = MyDG Range("G" & MyDA) = MyDH Range("H" & MyDA) = MyDI Range("I" & MyDA) = MyDJ Range("J" & MyDA) = MyDK Next MyDA End Sub

  • マクロ Outlook送信メールにエクセルの表を貼り付ける方法

    こんにちは。 送りたいメールの形は 数行の文章のあとに、表を貼り付け、また数行の文章という形式です。 Outlookメールでメールを立ち上げて Comment1と2は文章ですのでエクセルのコラムを引っ張ってくるようにしているのですが、 Comment3部分に別のエクセルにある表をメタ貼りし、Comment4でまた文書を引っ張ってくるとさせたいのですが Comment3部分の動きが出来ません。 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 '日付の設定 DMY = Range("b_date") DM = Format(Range("b_date").Value, "mmdd") Worksheets("mail").Activate 'Create Outlook object Set OutlookApp = New Outlook.Application 'Get the data Subj = Range("B69") & "_" & DM EmailAddr = Range("B63") CCAddr = Range("B66") Comment1 = Range("H63").Value Comment2 = Range("H65").Value Comment3 = この辺りがわかりません Comment4 =Range("H67").Value 'Compose message Msg = "<font face=""Arial""><font size=2>" Msg = Msg & Comment1 & "<BR><BR><BR>" Msg = Msg & Comment2 & "<BR><BR><BR>" Msg = Msg & Comment3 & "<BR><BR><BR>" Msg = Comment4 & "<BR><BR><BR><BR>" Msg = Msg & "Best regards," & "<BR><BR>" Msg = Msg & "</font></font>" 'Create Mail Item Set mItem = OutlookApp.CreateItem(olMailItem) With mItem .To = EmailAddr .CC = CCAddr .BCC = BCCAddr .Subject = Subj .HTMLBody = Msg .Display End With End Sub どなたかご存知ではないでしょうか? 毎回で申し訳ございませんが、どうぞ宜しくお願い致します。

  • Thunderbirdでファイル添付出来ません

    Excel請求書から出力したPDFファイルをメールソフトのThunderbirdでメールに添付して送信したいのですが、 添付ファイルのパスが間違っているのか「***.pdfファイルが存在しないためメッセージに添付できませんでした。」とエラーになってしまいます。 PDFファイル出力は問題無く出来ており、メール自体は作成できるところまでは出来ているのですが、肝心のファイル添付が出来なくて困っております、どなたかお助け願えませんでしょうか。 ※PDFファイルの保存場所は任意に選択⇒ファイル名は顧客名で都度出力される形になってます。 Sub PDF出力メール送信テスト用() Dim fname As String Dim pdfname1 As String Dim pdfname2 As String Dim rtn As Long Dim wsh As Object If MsgBox("PDFをメール送信する場合はOK、送信しない、または間違ってこのボタンをクリックした場合はキャンセルをクリックしてください。", vbOKCancel) = vbCancel Then End End If 'pdfname1は会社名、pdfname2は部署名、両方足して『顧客名.pdf』になるようにしています pdfname1 = Range("a4").Text pdfname2 = Range("a5").Text '保存ファイル名及び保存場所の設定 fname = Application.GetSaveAsFilename("【御請求書】" & pdfname1 & " " & pdfname2 & " 御中", "PDFファイル,*.pdf") 'キャンセルボタン押下時 If fname = "False" Then Exit Sub 'ファイルの存在確認 If Dir(fname) <> "" Then rtn = MsgBox(fname & " が存在します。上書きしますか?", vbOKCancel + vbQuestion, "確認") 'キャンセルボタン押下時 If rtn = vbCancel Then Exit Sub End If '印刷順にシートを並び替え Worksheets("請求書").Move Before:=Worksheets("請求書ひな形") Worksheets("請求書").Select Worksheets("請求書ひな形").Select False Worksheets("請求書ひな形").Activate ' 請求書PDF出力 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fname MsgBox fname & " 出力完了" '元通りにシートを並び替え Worksheets("請求書ひな形").Move Before:=Worksheets("請求書") Worksheets("請求書ひな形").Select Dim sPath As String Dim mailTo As String Dim subject As String Dim preface As String Dim mailBody As String Dim attachPath As String sPath = """C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe"" -compose " '送信先アドレスはExcelのx1セルに反映 mailTo = Range("x1").Value subject = "御請求書の送付について" preface = pdfname1 & pdfname2 & " 御中" & vbNewLine & vbNewLine & "いつもお世話になります。" & vbNewLine & "御請求書をお送り致しますのでご確認下さい。" & vbNewLine & vbNewLine & "以上、宜しくお願い致します。" mailBody = preface '添付ファイルのパスはfnameではダメなんでしょうか? attachPath = fname Shell sPath & "to=" & mailTo & ",subject=" & subject & ",body=" & mailBody & "," & "attachment=" & attachPath End Sub

  • ExcelのVBAについて質問です。Excelは2003です。

    ExcelのVBAについて質問です。Excelは2003です。 コマンドボタン1で下記のプログラムを実行するようにしています。 Sub Macro1() ' ' Macro1 Macro ' ' Dim iRows As Integer Dim sRows As String Dim i As Integer For i = 1 To 100 Application.Wait Now + TimeValue("00:00:05") ' 最終行の調査: iRows = Worksheets("Sheet1").UsedRange.Rows.Count ' 最終行をシート3にコピー Worksheets("Sheet1").Rows(iRows).Copy Destination:=Worksheets("Sheet4").Range("1:1") ' CH1 の最新データをシート3にコピー Worksheets("Sheet3").Range("B9").Value = Worksheets("Sheet1").Cells(iRows, 3).Value ' CH2 の最新データをシート3にコピー Worksheets("Sheet3").Range("C9").Value = Worksheets("Sheet1").Cells(iRows, 4).Value Next i End Sub これをコマンドボタン2で途中でも強制的に終了するようにしたいのですがコマンドボタン2にはどのようなプログラムを入れればいいでしょうか?

  • VBA CHANGEイベントに複数イベントを

    いつもお世話になっています。 色々しらべて試してみたんですが、うまくいかないんで教えてください。 CHANGEイベントに複数のイベントを書き込みたいんですが。 今現在、問題なく動いている以下のイベントがあります。 (1) Private Sub Worksheet_Change(ByVal Target As Range) Dim rang3 As Range Dim rang4 As Range Dim ■■ As String Dim LastRow1 As Long LastRow1 = Worksheets("○○").Cells(Rows.Count, "b").End(xlUp).Row Set rang4 = Worksheets("○○").Range("b:I" & LastRow) Set rang3 = Range("h4") If Intersect(Target, rang3) Is Nothing Then Exit Sub On Error Resume Next ■■ = WorksheetFunction.VLookup(Target.Value, rang4, 2, 0) If Err.Number > 0 Then MsgBox Target.Value & "はありません。基本情報台帳に入力してください。" Range("h4").Select Else Application.EnableEvents = False Range("I4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 2, False) Range("j4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 3, False) Range("k4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 7, False) Range("l4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 8, False) Range("m4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 5, False) Application.EnableEvents = True Range("K4").Select End If End Sub このシートにもう一つ、イベントを入れたいのですが。 (2) If Target.Count > 1 Then Exit Sub If Intersect(Target, Range("E4")) Is Nothing Then Exit Sub Else If Range("e4").Value = "1" Then Target.Offset(0, 19).Value = "☆" End If どこに入れればいいのかわかりません。 (3) また、(2)のイベントの他に、 (1)のVLOOLUPが実行され、尚且つ(2)のイベントのE4が値が1だった場合、Y4にH4の値を入れたいのですが・・・。 (2)のみなら動くことは確認できましたが、(1)のexit sub の直前に入れたり、end ifの前に入れたりしましたが、片方は動くが、もうひとつが動かないです。 (3)については、まったくわかりません。 マクロについて、自分でネットで勉強した程度なので、基本がわかっていないからなのでしょうが・・・。 どなたか、教えてください。 お願いします。

  • VBAでoutlook365が起動しません。

    VBAでoutlook365が起動しません。EXCELまたは、OUTLOOK設定がおかしいのでしょうか。 メール一括作成のボタンを押しても『記載に誤りが無いことを確認しましたか?』『"送信完了しました』のメッセージは出るのですが、outlookが起動しませんし下書ホルダにも保存されません。 EXCELは他のマクロは動作しますし、Outlookはセキュリティ(トラストセンター)設定も有効です。どなたかご教示いただけますようお願いいたします。 添付でEXCEL画面の画像と下記に対象の記述を記します。 ------------------------------------------------------- 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 End With End If i = i + 1 Loop Set objOutlook = Nothing MsgBox "送信完了しました" End Sub

  • 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

  • EXCEL VBA VLOOKUP 範囲を変数で

    Excel VBA で VLookup()の第2引数の範囲を行と列の数値の変数で指定したいのすが どのように記述すればよいでしょうか。 以下の式がエラーにならないように具体的に直していただけないでしょうか。 よろしくお願いします。 ----------------------------------- Dim d1 As String Dim d2 As String Dim r1 As Integer Dim r2 As Integer Dim c1 As Integer Dim c2 As Integer Dim c3 As Integer d1 = "愛知" r1 = 2 r2 = 782 c1 = 3 c2 = 5 c3 = 4 d2 = VLookup(d1, Worksheets("Sheet1").Range(Cells(r1, c1), Cells(r2, c2)), c3, False)

  • VBAが止まります。

    皆さん、いつもありがとうございます。 下から14行目の『 objMail.Attachments.Add asrs1』で止まってしまします。 下から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

専門家に質問してみよう