[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『EXCELのシートからデータを読み取ってOUTLOOKの下書きに保存したい』（超素人なぼくちゃん）
いつも大変お世話になっています。
以下のEXCELがSheet1にあった場合にこのデータを読みとって以下のOUTLOOKの下書きに保存したいです。
お忙しい中すみませんが教えてください。よろしくお願いいたします。
EXCELのSheet1
会社 部署 担当者 メールアドレス 番号 お名前 支払い額
AAA株式会社 A部署 高橋一郎 takahashi@XXXX.com 1234 花沢一郎 5000円
AAA株式会社 A部署 高橋一郎 takahashi@XXXX.com 2345 南沢ニ郎 3000円
AAA株式会社 A部署 高橋一郎 takahashi@XXXX.com 3456 北沢三郎 1000円
BBB株式会社 B部署 金子花子 kaneko123@yyyy.com 9876 西島卓也 1000円
BBB株式会社 B部署 金子花子 kaneko123@yyyy.com 8765 坂下拓三 5000円
CCC株式会社 C部署 米上淳ニ yoneue321@yyyy.com 7653 金上修一 2000円
CCC株式会社 C部署 米上淳ニ yoneue321@yyyy.com 9999 村川敬一 1000円
・
・
・
宛先:takahashi@XXXX.com
件名:支払いのご案内
AAA株式会社
A部署
高橋一郎 様
いつもお世話になっております。
標記の件支払い対象となりました。
支払い対象者
【番号】 1234
【お名前】花沢一郎 様
【支払額】5000円
【番号】 2345
【お名前】南沢ニ郎 様
【支払額】3000円
【番号】 3456
【お名前】北沢三郎 様
【支払額】1000円
以上、よろしくお願いいたします。
OUTLOOKの下書き 2件目
宛先:kaneko123@yyyy.com
件名:支払いのご案内
BBB株式会社
B部署
金子花子 様
いつもお世話になっております。
標記の件支払い対象となりました。
支払い対象者
【番号】 7653
【お名前】西島卓也 様
【支払額】1000円
【番号】 8765
【お名前】坂下拓三 様
【支払額】5000円
以上、よろしくお願いいたします。
OUTLOOKの下書き 3件目
宛先:yoneue321@yyyy.com
件名:支払いのご案内
CCC株式会社
C部署
米上淳ニ 様
いつもお世話になっております。
標記の件支払い対象となりました。
支払い対象者
【番号】 7653
【お名前】金上修一 様
【支払額】2000円
【番号】 9999
【お名前】坂下拓三 様
【支払額】1000円
以上、よろしくお願いいたします。
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
メールはHTMLですか？リッチテキストorテキストですか？ （稲葉） 2023/05/17(水) 09:37:49
提示いただいたフォームの通りで作っています。
列の順番が入れ替わったり増えたりすると使えなくなります。
Option Explicit
Sub メール下書き連続生成()
Dim tbl As Variant, rw As Long, cl As Long
Dim fld As Variant, w As Variant, s As String
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim strKey As String, k As Variant
Dim argCompany As Variant
Dim body_ As String, to_ As String
Dim msg As String
Dim テンプレ As String
テンプレ = " 【番号】 [番号]" & Chr(10) & _
" 【お名前】[お名前] 様" & Chr(10) & _
" 【支払額】[支払い額]" & Chr(10)
If OutLookChk = False Then
MsgBox "OutLookを開いてから実行してください"
End If
'データの取得。シート名やセル範囲は適宜修正してください。 項目名は必ず1行目にしてください。
With Sheets("Sheet1")
tbl = .Range("G1", .Cells(Rows.Count, "A").End(xlUp)).Value
End With
'項目名の取得 テンプレの書き換えに必要
fld = Application.Index(tbl, 1, 0)
'繰り返し処理
For rw = 2 To UBound(tbl, 1)
'wにtblの1行切り取ったデータを入れる
w = Application.Index(tbl, rw, 0)
'dicrionaryのキーに入れる 会社～メールアドレスまでを一意の値として認識させる
strKey = Join(Array(w(1), w(2), w(3), w(4)), Chr(2))
'テンプレの[項目名]部分をデータに置き換える
s = ""
For cl = 5 To UBound(w) '番号～支払額
s = Replace(IIf(s = "", テンプレ, s), "[" & fld(cl) & "]", w(cl))
Next cl
'同じキーの場所につなぐ
dic(strKey) = dic(strKey) & Chr(10) & s
Next rw
'下書き作成処理
For Each k In dic.keys
argCompany = Split(k, Chr(2))
body_ = argCompany(0) & Chr(10) & _
argCompany(1) & Chr(10) & _
argCompany(2) & "様" & Chr(10) & Chr(10) & _
"いつもお世話になっております｡" & Chr(10) & _
"標記の件支払い対象となりました｡ " & Chr(10) & _
"支払い対象者 " & Chr(10) & _
dic(k)
to_ = argCompany(3)
If メール送信(False, to_, "", "支払いのご案内", body_) = 1 Then
msg = msg & k & ":" & "成功" & Chr(10)
Else
msg = msg & k & ":" & "失敗" & Chr(10)
End If
Next k
MsgBox msg
End Sub
Function OutLookChk() As Boolean
'アウトルックのオブジェクトチェック
'objOLにGetObjectで変数を格納できなければ、On Errorステートメントのエラーになるので
'エラーを返す
'回避方法はアウトルックを開いてから実行すること
Dim objOL As Object
OutLookChk = True
On Error Resume Next
Err.Clear
Set objOL = GetObject(, "Outlook.Application")
If Err > 0 Then OutLookChk = False
Err.Clear
On Error GoTo 0
Set objOL = Nothing
End Function
Function メール送信(送信 As Boolean, 宛先 As String, CC As String, 件名 As String, 本文 As String, ParamArray 添付()) As Long
'OutLookの立上げはチェックしていないので、事前にチェックする
'0 = 失敗 1 = 成功
'OlBodyFormat 列挙
Const olFormatHTML = 2 'HTML 形式
Const olFormatPlain = 1 'テキスト形式
Const olFormatRichText = 3 'リッチ テキスト形式
Const olFormatUnspecified = 0 '形式の指定なし
'CreateItem定数
Const olMailItem = 0 'メールメッセージ
Const olAppointmentItem = 1 '予定アイテム
Dim i As Long
With CreateObject("Outlook.Application")
On Error GoTo errHandler
With .createitem(olMailItem)
.BodyFormat = olFormatRichText
.To = 宛先
.CC = CC
.Subject = 件名
.body = 本文
If IsMissing(添付) = False Then
For i = 0 To UBound(添付)
.Attachments.Add 添付(i)
Next i
End If
If 送信 = True Then
.Send '直接送信箱行き
Else
.Save '下書き保存
'.display '表示
End If
メール送信 = 1
End With
On Error GoTo 0
End With
Exit Function
errHandler:
End Function
（稲葉） 2023/05/17(水) 11:05:45
実際に詰まっていた部分がわかりませんでしたし、HTML形式を前提にしているものになりますが、私の場合、コード中にメール内容を全部書くのではなく、テンプレート（oftファイル）を作成しておき置換で差し込み対応してます。
リッチテキスト形式でも考え方の参考にはなろうかとおもいますので研究材料として提示しておきます。
Sub メール作成マクロ()
Dim mailOBJ As Object
Dim i As Long
Dim 列 As Long
Dim テンプレ As String
テンプレ = Application.GetOpenFilename("メールテンプレート,*.oft")
With ThisWorkbook.Worksheets("送付先リスト")
For i = 6 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(i, "A").Value = "送信対象" Then
Set mailOBJ = CreateObject("Outlook.Application").CreateItemFromTemplate(テンプレ)
'▼宛先（To）をセット
mailOBJ.To = Replace(.Cells(i, "D").Value, vbLf, ";")
'▼宛先（Cc）をセット
mailOBJ.cc = Replace(.Cells(i, "E").Value, vbLf, ";")
'▼宛先（Bcc）をセット
mailOBJ.bcc = Replace(.Cells(i, "F").Value, vbLf, ";")
'▼件名をセット
mailOBJ.Subject = .Cells(i, "G").Value
'▼本文内の宛先名を差し込み（置換）
mailOBJ.HTMLBody = Replace(mailOBJ.HTMLBody, "【あてさきめい】", Replace(.Cells(i, "H").Value, vbLf, "<br>"))
'▼本文の必要箇所に差し込み（置換）
mailOBJ.HTMLBody = Replace(mailOBJ.HTMLBody, "【さしこみ１】", Replace(.Cells(i, "I").Value, vbLf, "<br>"))
mailOBJ.HTMLBody = Replace(mailOBJ.HTMLBody, "【さしこみ２】", Replace(.Cells(i, "J").Value, vbLf, "<br>"))
mailOBJ.HTMLBody = Replace(mailOBJ.HTMLBody, "【さしこみ３】", Replace(.Cells(i, "K").Value, vbLf, "<br>"))
mailOBJ.HTMLBody = Replace(mailOBJ.HTMLBody, "【さしこみ４】", Replace(.Cells(i, "L").Value, vbLf, "<br>"))
mailOBJ.save
.Cells(i, "A").Value = "済"
End If
Next i
End With
End Sub
（もこな２） 2023/05/17(水) 19:16:52
なるほど、テンプレート使うのもいいですねぇ。 今回は会社名毎にひとつにまとめる処理がポイントだったと思うので そちらについても言及されないと、動かしてみて混乱されてしまうかも？ （稲葉） 2023/05/18(木) 02:56:19
トライした上での具体的な質問があれば考えますけど、たとえば作業用シートに会社単位で【抽出】して、それをメールにコピペするというアプローチでもイケそうな気がします。
（試していませんから確証ないですが、リッチテキスト形式の場合、何文字目という指定で任意の箇所に挿入できたかとおもいます。）
（もこな２） 2023/05/18(木) 08:38:55
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.