お世話になります。
コードをネットで確認しながら作っている状態になります。
やりたいことは、「DR2更新日」シートで、更新日をフィルターで指定して、そのデータのみ
メールに貼り付けたいと思っております。
下記のコードだと、最新更新日より、前の日を指定すると、最新日までのデータが全て出て
きてしまうのです。
※例:12/15を指定するのですが、12/15-12/19までのデータが表示されてしまいます。
「DR2更新日」シートは、指定日だけ表示しております。
「DR2Mail」シートの方は、最新日までデータが貼り付けられています。
メールの本文には、「DR2Mail」シートに表示されているデータが貼り付けられております。
お忙しいとは思いますが宜しくお願い致します。
☆★☆★☆★☆★☆★☆★☆★☆★★☆☆★☆★☆★☆★☆★☆★☆★☆★☆
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
Dim objMail As Outlook.MailItem
Set objMail = objOutlook.CreateItem(olMailItem)
Dim objTableRG As Range
Dim objWRG As Word.Range
Dim strPastePos As String
strPastePos = "＜表挿入位置＞"
'--- メールの内容を格納する変数 ---'
Dim toStr As String
Dim ccStr As String
Dim bccStr As String
Dim subjectStr As String
Dim bodyStr As String
Dim bodyStr1 As String
Dim bodyStr2 As String
'データをコピー
Worksheets("DR2Mail").Select
Dim c As Range ' 2 行目以降をクリアする:前処理
Dim a,b
Set c = Cells ' シート全体
c.Resize(RowSize:=c.Rows.Count - 1).Offset(1, 0).Clear ' 2 行目以降をクリア
Worksheets("DR2更新日").Select
b = Worksheets("DR2更新日").UsedRange.Rows.Count 'DR2更新日の行数
'DR2更新日のデータを記録
a = Range(Range("A2"), Range("G" & Rows.Count).End(xlUp)).Value 'A-Gまでの情報を取得
'DR2Mailに新規アイテムのプライズ番号を貼り付ける
Worksheets("DR2Mail").Select
Range("H1") = Now 'AAに取り込み日時を記載する
i = 1
For i = 1 To b - 1
Cells(i + 1, 1) = a(i, 1) 'A列に貼り付ける
Cells(i + 1, 2) = a(i, 2) 'B列に貼り付ける
Cells(i + 1, 3) = a(i, 3) 'C列に貼り付ける
Cells(i + 1, 4) = a(i, 4) 'D列に貼り付ける
Cells(i + 1, 5) = a(i, 5) 'E列に貼り付ける
Cells(i + 1, 6) = a(i, 6) 'F列に貼り付ける
Cells(i + 1, 7) = a(i, 7) 'G列に貼り付ける
On Error GoTo tsugi
Next i
'データをコピーここまで
tsugi:
'--- 宛先の内容 ---'
toStr = "test_Main@test.com"
ccStr = "test_Cc@test.com"
'--- 件名の内容 ---'
subjectStr = "【更新】更新データのの発行 " & Date & " 付DR更新分" '件名
'--- 本文の内容 ---'
'メール本文
bodyStr = bodyStr + "ご担当者 各位" & Chr(13) & Chr(10)
bodyStr = bodyStr + "お疲れ様です、データ配信の担当です。" & Chr(13) & Chr(10)
bodyStr = bodyStr & Chr(13) & Chr(10)
bodyStr = bodyStr + "メールにて更新状況をお知らせさせていただきま。" & Chr(13) & Chr(10)
bodyStr = bodyStr + "下記の゛ーテタをご確認頂けますでしょうか" & Chr(13) & Chr(10)
bodyStr = bodyStr & Chr(13) & Chr(10)
bodyStr = bodyStr & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 + "以上、よろしくお願いします。" & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & "■□■□■□■□■□■□■□■□■□■□■□■□" & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & "株式会社 テスト" & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & "データ配信部" & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & "データ配信担当者" & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & "E-mail：test@test" & Chr(13) & Chr(10)
bodyStr2 = bodyStr2 & "■□■□■□■□■□■□■□■□■□■□■□■□" & Chr(13) & Chr(10)
bodyStr1 = bodyStr & Chr(13) & Chr(10) & "＜表挿入位置＞" & bodyStr2
'--- 条件を設定 ---'
objMail.To = toStr
objMail.CC = ccStr
objMail.Subject = subjectStr
objMail.Body = bodyStr1
objMail.BodyFormat = 3 ' 「3」の場合リッチテキスト型となります。「1」はテキスト型、「2」は HTML型となります。
'--- Excelワークシート ---'
Dim ws As Worksheet
Dim 最終行
最終行 = 0
Set ws = ThisWorkbook.Worksheets("DR2Mail")
'--- 貼り付ける表の範囲（A1:H10のような文字列） ---'
Dim tableAddress As String
'DR2更新日のデータ範囲を取得
Worksheets("DR2Mail").Activate
最終行 = Range("A2").End(xlDown).Row
tableAddress = "A1:" & "G" & 最終行
MsgBox tableAddress
'--- メール本文に表を貼り付け ---'
Call ws.Range(tableAddress).Copy
objMail.GetInspector().WordEditor.Windows(1).Selection.EndKey Unit:=6, Extend:=0
Set objWRG = objMail.GetInspector.WordEditor.Range(0, 0)
objWRG.Find.Text = strPastePos
objWRG.Find.Execute
objWRG.Paste
'--- メールを表示 ---'
objMail.Display
