[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『抽出と送信の繰り返し』（初心者）
VBA初心者です。
エクセルを使って、各社へ対象のエリア情報をメールで送信できるようにしたいと考えています。
下記のようなリストについて、社名でフィルターをかけ、メール本文にエリア情報を張りつけ（図書式）、送信するというのを全ての業者さんに繰り返し行いたいです。
エリア 契約順 契約期間 取り扱い名称 社名
東京１ 1 ー 商品 A社
東京２ 2 ー 商品 A社
東京３ 3 ー 商品 A社
東京４ 4 ー 商品 A社
東京５ 5 ー 商品 A社
東京６ 6 ー 商品 A社
東京７ 7 ー 商品 A社
東京８ 8 ー 商品 A社
東京９ 9 ー 商品 A社
東京１０ 10 ー 商品 A社
東京１１ 11 ー 商品 A社
東京１２ 12 ー 商品 A社
東京１３ 13 ー 商品 A社
東京１４ 14 ー 商品 A社
東京１５ 15 ー 商品 A社
東京１６ 16 ー 商品 A社
東京１７ 17 ー 商品 A社
東京１８ 18 ー 商品 A社
東京１９ 19 ー 商品 A社
東京２０ 20 ー 商品 A社
東京２１ 21 ー 商品 A社
東京２２ 22 ー 商品 B社
東京２３ 23 ー 商品 B社
東京２４ 24 ー 商品 B社
東京２５ 25 ー 商品 B社
抽出・貼り付け・送信・貼り付けと既に抽出したものの削除を繰り返せばいいんだと思っているのですが、初心者の私には、テキスト等を読んでも理解できないことが多く、なかなかうまくいきません。
今後とも勉強していきたいとは思っているのですが、どうしても上手くいかないため、どなたかアドバイス頂けますと幸いです…。
＜ 使用 Excel：Excel2010、使用 OS：unknown ＞
やる手順（操作方法含む）を箇条書きにしておけば良いんじゃないですか・・・。 で、どの辺が理解出来なのでしょうか?
>初心者の私には、テキスト等を読んでも理解できないことが多く、なかなかうまくいきません。
いつまでたってもこれでは、仕事にならんと思うので、繰り返し覚えるしかないと思うけど・・・・ ま、人の事言えんけどね。
>VBA初心者です。
あ、VBAね。 初心者にもなってないのでは・・・。（誰に聞いたか面倒なだけ？）
（BJ） 2019/07/11(木) 19:40
全く触ったことないくらいです。
仰るとおり初心者ですらないですね…。
急遽仕事で急ぎ作ってみて、と言われ困っております…。
なんとか理解しようとテキストやサイトをまわって調べてみたはいいものの、どうしてもうまくいきません。
なので勉強しつつどなたかにアドバイス頂ければと思った次第です。
やることとしては
?@社名ごとに抽出
?A抽出した社名に該当するエリアをコピー
?Bメール本文に図書式で貼り付け
?C送信
?D貼り付けた図を削除
を繰り返しかと…
（初心者） 2019/07/12(金) 09:18
回答頂きありがとうございます。
メール送信のやり方は思考錯誤して、なんとかわかりました！
テストデータを作ってみましたが、きちんと送れました。ありがとうございます。
色々なサイトから引っ張ってきて、作ってはみたのですがどうも抽出と貼り付けがうまくいかないようで…
抽出できたと思ったら１社のみ抽出して他は消えてしまったり、デバックするとRangeメソッドのエラーが出たりと…なかなかに難しいですね…。
事務職の人間でして今まで全くマクロに触れてきたことがないため調べながらなんとか…といった感じです…。
サイトからひっぱて来て下記のコードで抽出をし、メールに図で貼り付け・送信を業者さん毎に繰り返したいのですが、そもそもこのコードも実行できず、どこが違うか分からないで困っております。
shF.Columns("AL").Copy shF.Range("AO")のところでRangeメソッドエラーが出ているようです。
Sub 抽出()
Dim shF As Worksheet
Dim shT As Worksheet
Set shF = Sheets("リスト")
Set shT = Sheets("抽出貼り付け")
shT.Columns("A:AL").ClearContents
shT.Range("A2:AL2").Value = shF.Range("A2:AL2").Value
shF.Columns("AL").Copy shF.Range("AO")
Do While Not IsEmpty(shF.Range("AO3"))
shF.Range("AL3").Value = "'=" & shF.Range("AO3").Value
'フィルターオプションによる抽出
shF.Range("AL3").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=shF.Range("B:D"), CopyToRange:=shT.Range("B:D"), Unique:=False
ここに図でコピーするコードいれる予定です
MsgBox "確認してください"
Loop
（初心者） 2019/07/12(金) 11:08
とりあえず気が付いた点だけ＾＾
shF.Columns("AL").Copy shF.Range("AO")
↑
ＡＯだけで（列情報）次の行情報が1～最終行が無いのでコピーできないのでは
無いでしょうか。
あと、現在確認中です。。。リストの情報をセル番地の解るものを可能であれば
教えて下さい（もちろんダミー情報でＯＫです）← わたしが解るかど～かわかりませんが＾＾；
他の方が回答下さるかもしれません。
（隠居じーさん） 2019/07/12(金) 11:55
A B C D E F
1 エリア 契約順 契約期間 取り扱い名称 社名 A
2 東京１ 1 ー 商品 A社 1
3 東京２ 2 ー 商品 A社 1
4 東京３ 3 ー 商品 A社 1 ... ～ ＡＬ列まで？
5 東京４ 4 ー 商品 A社 1
6 東京５ 5 ー 商品 A社 1
7 東京６ 6 ー 商品 A社 1
8 東京７ 7 ー 商品 A社 1
9 東京８ 8 ー 商品 A社 1
↓
こんな感じで表形式で。。。Ｅ列の社名でフイルターをかけるで良いのでしょうか。 多分予想、大間違い＾＾；だと思いますのでご修正を。。。m(_ _)m （隠居じーさん） 2019/07/12(金) 12:13
私の場合、フィルタオプションよりオートフィルタが好きなので、そちらで考えてみました。
【データ】シート
______A________B_________C__________D____________E_____ 1 エリア 契約順 契約期間 取り扱い名称 社名 2 東京１ 1 ー 商品 A社 3 東京２ 2 ー 商品 C社 4 東京３ 3 ー 商品 B社 5 東京１ 4 ー 商品 B社 6 東京３ 5 ー 商品 B社 7 東京４ 6 ー 商品 A社 8 東京２ 7 ー 商品 A社 9 東京５ 8 ー 商品 C社 10 東京６ 9 ー 商品 A社
↓ オートフィルタでA社を抽出
______A________B_________C__________D____________E_____ 1 エリア 契約順 契約期間 取り扱い名称 社名 2 東京１ 1 ー 商品 A社 7 東京４ 6 ー 商品 A社 8 東京２ 7 ー 商品 A社 10 東京６ 1 ー 商品 A社
↓ 一旦、貼付用のシートにコピー
上記を図としてコピーしてから、Html形式のメールに貼付
html形式のメール本文へ
Sub さんぷる()
Const 社名 As String = "A社"
'▼表を【図としてコピー】
With ThisWorkbook.Worksheets("データ")
.Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=5, Criteria1:=社名
ThisWorkbook.Worksheets("貼付用").UsedRange.Clear
.AutoFilter.Range.Copy ThisWorkbook.Worksheets("貼付用").Range("A1")
ThisWorkbook.Worksheets("貼付用").Range("A1").CurrentRegion.CopyPicture Appearance:=xlScreen, Format:=xlPicture '図としてコピー
End With
'▼outlookオブジェクトを生成
With CreateObject("Outlook.Application")
'▼新規メールを生成
With .CreateItem(olMailItem)
.BodyFormat = olFormatHTML
.Subject = 社名 & "御中 表の送付について"
.Display
With .GetInspector.WordEditor.Windows(1).Selection
.TypeText 社名 & " ご担当者様" & vbCrLf & vbCrLf & _
"おせわになっております。表を送ります。" & vbCrLf
.Paste
.TypeText vbCrLf & vbCrLf & "差出人 誰某"
End With
End With
End With
End Sub
↑で思うとおりになるのであれば、社名が順番に入れ替るような処理を考えれば良さそうです。
（もこな２） 2019/07/12(金) 12:48
ご丁寧に指摘頂きありがとうございます。
途方にくれておりましたので、丁寧な対応がとても嬉しいです。
最初のコメントに載せた表はかなり簡素化したものでして…実際は上記のE列（社名）がAL列にある下記のようなデータなんです。
簡素化したほうが見易いかと思ったのですが失敗でした。大変失礼致しました。
C D E F G … AL AM AN
エリア 品名 品名cd 略名 価各…正式社名 メアド 担当者様名
東京１ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
東京２ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
東京３ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
東京４ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
東京５ おかし 88888888 A社 ××…A株式会社 ○○.jp 田中様
東京６ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
東京７ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
東京８ おかし 88888888B社 ××…株式会社B ○○.jp 上田様
東京９ 野菜 55555555A社 ××…A株式会社 ○○.jp 田中様
東京１０ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
東京１１ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
東京１２ おかし 88888888B社 ××…株式会社B ○○.jp 上田様
東京１３ おかし 88888888B社 ××…株式会社B ○○.jp 上田様
東京１４ 野菜 55555555B社 ××…株式会社B ○○.jp 上田様
東京１５ おかし 88888888B社 ××…株式会社B ○○.jp 上田様
東京１６ おかし 88888888B社 ××…株式会社B ○○.jp 上田様
広島１ おかし 88888888B社 ××…株式会社B ○○.jp 上田様
広島２ おかし 88888888B社 ××…株式会社B ○○.jp 上田様
広島３ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
広島４ 野菜 55555555A社 ××…A株式会社 ○○.jp 田中様
広島５ 野菜 55555555A社 ××…A株式会社 ○○.jp 田中様
広島６ おかし 88888888C社 ××…有限会社C ○○.jp 山本様
神戸３ おかし 88888888C社 ××…有限会社C ○○.jp 山本様
神戸４ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
神戸５ おかし 88888888A社 ××…A株式会社 ○○.jp 田中様
正式社名で抽出し、VLOOKUPで表示してあるメアド宛に担当者様宛てに送りたいと思っています。
（内容を変えて送信するコードはなんとか成功しました）
メールだと
To A社メアド
件名 エリア情報
本文 A株式会社 田中様
本文 いつも大変お世話になっております。
本文 ８月分のエリアをお知らせします。
本文 つきましては、納品予定を教えて頂けますか？
本文 15日まで回答にお願い致します。
抽出リスト貼り付け（図書式）
東京１ おかし
東京２ おかし
東京３ おかし
東京４ おかし
東京５ おかし
東京６ おかし
東京７ おかし
東京９ 野菜
東京１０ おかし
東京１１ おかし
広島３ おかし
広島４ 野菜
広島５ 野菜
神戸４ おかし
神戸５ おかし
署名(クレジット)
というのを理想にしているのですが…。
すこしでも助言頂けますと助かります。
お忙しい中恐れ入りますが何卒宜しくお願い致します。
長々と大変も申し訳ありません…。
（初心者） 2019/07/12(金) 13:48
ご丁寧にありがとうございます！
早速コードを参考にさせていただきます！
本当にありがとうございます。
（初心者） 2019/07/12(金) 13:49
ちょっとレベルが高いかもしれませんが、いろいろと応用が利くと思いますので
ご参考ください
列名は適当ですので、適宜変えてくださいね
Option Explicit
Sub test()
'Microsoft Spricting Runtime を参照設定
'Outlook.Applicationを参照設定
Dim myData '送付用元データ
Dim myMailDic As New Scripting.Dictionary
Dim myOlApp As New Outlook.Application
Dim myMailItem As Outlook.MailItem
Dim i As Long
Dim myKey As String
Dim myKeyItem As Variant
Dim myKeyAr As Variant
Const myHeader As String = _
"いつも大変お世話になっております｡" & vbCrLf & _
"８月分のエリアをお知らせします。" & vbCrLf & _
"つきましては、納品予定を教えて頂けますか？" & vbCrLf & _
"本文 15日まで回答にお願い致します。"
Const myFooter As String = _
"署名"
'データを配列で所得、見出し行は除く
With ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
myData = .Offset(1).Resize(.Rows.Count - 1)
End With
For i = LBound(myData, 1) To UBound(myData, 1)
'エリア名、略名、メアド、担当者名をキーとする。列は調整して下さい
myKey = myData(i, 3) & "|" & myData(i, 5) & "|" & myData(i, 6) & "|" & myData(i, 7)
If myMailDic.Exists(myKey) = True Then
'すでに出現しているキーなら、品名文字列を追加
myMailDic(myKey) = myMailDic(myKey) & vbCrLf & myData(i, 4)
Else
'初めてのキーなら、ヘッダと品目名をセット
myMailDic.Add myKey, myData(i, 5) & " " & myData(i, 7) & "様" & vbCrLf & myHeader & vbCrLf & myData(i, 4)
End If
Next
'この時点でユニークなキーにそれぞれのメール本文が格納されているので
'それぞれをメールする
For Each myKeyItem In myMailDic.Keys
myKeyAr = Split(CStr(myKeyItem), "|")
Set myMailItem = myOlApp.CreateItem(olMailItem)
With myMailItem
.To = myKeyAr(2) 'メアド
.Subject = myKeyAr(0) 'エリア情報
.HTMLBody = myMailDic(myKeyItem) & vbCrLf & vbCrLf & myFooter
.Send
End With
Next
Set myMailDic = Nothing
Set myOlApp = Nothing
End Sub
（渡辺ひかる） 2019/07/12(金) 16:41
【データ】シート
___C________D__________E_________F______G__…
1 エリア 品名 品名cd 略名 価格…
2 東京１ おかし 88888888 A社 ××…
3 東京２ おかし 88888888 A社 ××…
4 東京３ おかし 88888888 A社 ××…
5 東京４ おかし 88888888 A社 ××…
6 東京５ おかし 88888888 A社 ××…
7 東京６ おかし 88888888 A社 ××…
8 東京７ おかし 88888888 A社 ××…
9 東京８ おかし 88888888 B社 ××…
10 東京９ 野菜 55555555 A社 ××…
11 東京１０ おかし 88888888 A社 ××…
12 東京１１ おかし 88888888 A社 ××…
13 東京１２ おかし 88888888 B社 ××…
14 東京１３ おかし 88888888 B社 ××…
15 東京１４ 野菜 55555555 B社 ××…
16 東京１５ おかし 88888888 B社 ××…
17 東京１６ おかし 88888888 B社 ××…
18 広島１ おかし 88888888 B社 ××…
19 広島２ おかし 88888888 B社 ××…
20 広島３ おかし 88888888 A社 ××…
21 広島４ 野菜 55555555 A社 ××…
22 広島５ 野菜 55555555 A社 ××…
23 広島６ おかし 88888888 C社 ××…
24 神戸３ おかし 88888888 C社 ××…
25 神戸４ おかし 88888888 A社 ××…
26 神戸５ おかし 88888888 A社 ××…
【送付先】シート
______A______B__________C_________D__________E__ 1 略名 正式社名 メアド 担当者様名 フラグ 2 A社 A株式会社 ○○.jp 田中様 3 B社 株式会社B ○○.jp 上田様 済 4 C社 有限会社C ○○.jp 山本様
その上で、たとえば【送付先】シートの2行目からループ処理で順番にフラグが済みになっていないものだけ処理とか。。。。
また、作成したメールを自動送信するようにもできるでしょうけど、そのような改造は安定動作を確認してからの方がよいです。
（以前、ループ処理をミスって同じメールを30通ほど取引先に送付したことがあります・・・）
また、図としてコピーを紹介しておいてですが、画像ファイルとして送った場合、相手方が活用しづらいので渡辺ひかるさんが仰るように、テキストなり、表なりで送った方が良いこともあるかもしれません。
（もこな２） 2019/07/12(金) 18:57
こんにちは ＾＾ テキスト版は 渡辺ひかる さん 図形版は もこな２ さん がご案内のようでしたのでHTML。。。なぞ。。。例の如く力技のごりおしコードで恐縮です。 遅延バインディング。署名は固定です。ご必要でしたら （C:\Users\[??ユーザ名???]\AppData\Roaming\Microsoft\Signatures）あたりにあるファイル を読み込んで所定の箇所に継ぎ足しを。。＾＾： HTML部は書き出さずともテキストで良いかもしれませんがもう一工夫すれば送信ログにも使え 無くはないかと思うのと見やすいかなと思いました。← 私だけかも A^_^; cssはヘッダーで括らず、個別に要素ごとにスタイル指定した方が型崩れしにくいそぉ～ですが 今回は手抜きで。。。^^;;;きっともっとスマートな方法が有ると思います。 外していましたらお許しを。
Option Explicit
Sub OneInstance()
Const MySign As String = "署名 XXX 2019"
Dim D As Object
Dim Mi As Object
Dim Ml As Object
Dim Mfd As Object
Dim Ns As Object
Dim Mitem As Object
Dim Fs As Object
Dim Mf As Object
Dim Rr As Range
Dim Ws As Worksheet
Dim Honbun As String
Dim Docs As String
Dim i As Long
Dim j As Long
Dim Msg As Variant
On Error GoTo StepE
Msg = Array("いつも大変お世話になっております｡", _
"８月分のエリアをお知らせします。", _
"つきましては、納品予定を教えて頂けますか？", _
"15日まで回答にお願い致します。", "エリア情報")
For i = 0 To UBound(Msg) - 1
Honbun = Honbun & "<div>" & Msg(i) & "</div>" & vbCrLf
Next
Set Fs = CreateObject("Scripting.FileSystemObject")
Set Ml = CreateObject("Outlook.Application")
Set Ns = Ml.GetNamespace("MAPI")
Set Mfd = Ns.GetDefaultFolder(4)
Set D = CreateObject("Scripting.Dictionary")
If Not Evaluate("=ISREF(抽出貼り付け!A1)") Then Sheets.Add.Name = "抽出貼り付け"
Set Ws = Worksheets("抽出貼り付け")
With Sheets("リスト")
For i = 2 To .Cells(Rows.Count, 38).End(xlUp).Row
If Not D.Exists(.Cells(i, 38).Value) Then
D.Add .Cells(i, 38).Value, Array(.Cells(i, 38), .Cells(i, 39), .Cells(i, 40))
End If
Next
Ws.UsedRange.Clear
Intersect(.UsedRange, .Range("C:D,AL:AL")).Copy Ws.Cells(1)
End With
With Ws
Set Rr = .Cells(1).CurrentRegion
For i = 0 To D.Count - 1
If .FilterMode = True Then Rr.FilterMode = False
.Range("F1").Resize(2) = WorksheetFunction.Transpose(Array(Rr(1, Rr.Columns.Count), D.Items()(i)(0)))
Rr.AdvancedFilter xlFilterCopy, .Range("F1").CurrentRegion, .Range("I1")
Open ThisWorkbook.Path & "\" & "Mail.html" For Output As #1
Print #1, "<html>"
Print #1, "<head>"
Print #1, "<style type=""Text/css"">"
Print #1, "div {font-size:20px; padding:1px; margin:1px;}"
Print #1, "td,th {border:1px dotted #00aaff;text-align:left;width:100px;padding:2px 10px;font-size:20px;}"
Print #1, "</style>"
Print #1, "</head>"
Print #1, "<Body>"
Print #1, "<pre><div>" & D.Items()(i)(0) & " " & D.Items()(i)(2) & "</div></pre>"
Print #1, Honbun
Print #1, "<div> </div>"
Print #1, "<table>"
For j = 1 To .Cells(.Rows.Count, 9).End(xlUp).Row
Print #1, "<tr><td>" & .Cells(j, 9) & "</td><td>" & .Cells(j, 10) & "</td></tr>"
Next
Print #1, "</table>"
Print #1, "<div> </div>"
Print #1, "<pre><div>" & MySign & "</div></pre>"
Print #1, "</body>"
Print #1, "</html>"
Close #1
'ForReading = 1
Set Mf = Fs.OpenTextFile(ThisWorkbook.Path & "\Mail.html", 1)
Docs = Mf.ReadAll
Mf.Close
'olMailItem = 0
Set Mitem = Ml.CreateItem(0)
With Mitem
.To = D.Items()(i)(1)
.Subject = Msg(UBound(Msg))
'olFormatHTML = 2
.BodyFormat = 2
.HTMLBody = Docs
.Display
End With
Set Mitem = Nothing
.Range("F:Z").Clear
Next
End With
Kill ThisWorkbook.Path & "\" & "Mail.html"
'送信トレイ
Set Mi = Mfd.Items
Do While Mi.Count > 0
DoEvents
Loop
MsgBox "OutLookを終了します"
Ml.Quit
Set Mi = Nothing
Set Mf = Nothing
Set D = Nothing
Set Ml = Nothing
Set Mfd = Nothing
Set Ns = Nothing
Set Fs = Nothing
Set Ws = Nothing
Set Rr = Nothing
Exit Sub
StepE:
MsgBox "原因不明のエラーです。確認後再起動してください。" & _
err.Number & " : " & Chr(13) & err.Description, vbCritical, "VBA-ERRMSG"
If Not Ml Is Nothing Then
Ml.Quit
End If
Set Mi = Nothing
Set Mf = Nothing
Set D = Nothing
Set Ml = Nothing
Set Mfd = Nothing
Set Ns = Nothing
Set Fs = Nothing
Set Ws = Nothing
Set Rr = Nothing
End Sub
（隠居じーさん） 2019/07/16(火) 15:04
教えて頂いたコードの意味や仕組みについて調べながら進めておりましたらこんなに日が空いてしまいました。すみません…。成功しました！という報告をしたかったのですが、ｖｂCrlｆがHTMLでは改行されなかったり、業者１つ分しか抽出されなかったり…まだまだかかりそうでしたので先にお礼と思い、書き込みさせて頂きました。
本当にありがとうございます。
恐らくはHTMLの改行用にｂｒへ変えればいいのと、何か範囲選択を間違えているんだと思います…。もう少しだと思うので、頑張ります！
（初心者） 2019/07/19(金) 16:57
やっつけコードですが↓で表付きのhtml形式のメールは作成できるとおもいます。
（Excel2016/Outlook2016／Windows10 でチェック済）
Sub さんぷる()
Dim i As Long
Dim 略名 As String
Dim 社名 As String
Dim 担当 As String
With ThisWorkbook.Worksheets("データ")
.Range("A1").AutoFilter
For i = 2 To Worksheets("送付先").Cells(Rows.Count, "A").End(xlUp).Row
If Worksheets("送付先").Cells(i, "E").Value <> "済" Then
略名 = Worksheets("送付先").Cells(i, "A").Value
社名 = Worksheets("送付先").Cells(i, "B").Value
担当 = Worksheets("送付先").Cells(i, "D").Value
.Range("C1").AutoFilter Field:=4, Criteria1:=略名
'抽出されたものを普通にコピー
.AutoFilter.Range.Copy
'▼outlookオブジェクトを生成
With CreateObject("Outlook.Application")
'▼新規メールを生成
With .CreateItem(olMailItem)
.BodyFormat = olFormatHTML
.To = Worksheets("送付先").Cells(i, "C").Value
.Subject = 社名 & " 御中 表の送付について"
.Display
With .GetInspector.WordEditor.Windows(1).Selection
.TypeText 社名 & " " & 担当 & vbCrLf & vbCrLf & _
"おせわになっております。表を送ります。" & vbCrLf
.Paste
.TypeText vbCrLf & vbCrLf & "差出人 誰某"
End With
End With
End With
End If
Next i
End With
End Sub
（もこな２） 2019/07/19(金) 22:16
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.