[[20211126195810]]　『Outlookメール本文にExcelの表を貼り付ける方法』（dokom）　ページの最後に飛ぶ

『Outlookメール本文にExcelの表を貼り付ける方法』（dokom）

【新規】の後に貼り付けた後に【変更】の後に貼り付けしたいです。
お分かりになる方教えていただけますでしょうか。

Sub CreatePivotTable()

  Application.DisplayAlerts = False

  Dim ws As Worksheet

  For Each ws In Worksheets
    If ws.Name = "当日件数" Then
      ws.Delete
    End If
  Next ws

  Application.DisplayAlerts = True

    'プログラム2｜シート設定
    Set ws = Worksheets("選任マスタ(Y)")

    'プログラム3｜ピボットキャッシュを生成
    Dim pc As PivotCache
    Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ws.Range("A1").CurrentRegion.Address)

    'プログラム4｜ピボットテーブルを作成
    Dim pt As PivotTable
    Set pt = pc.CreatePivotTable(tabledestination:=Sheets.Add.Range("A1"), TableName:="pivot1")

    'プログラム5｜ピボットテーブルのフィールド設定
    With pt

        'プログラム6｜行フィールドを設定
        With .PivotFields("BU")
            .Orientation = xlRowField
        End With

        'プログラム7｜列フィールドを設定
        .PivotFields("売上区分名").Orientation = xlColumnField

        'プログラム8｜値フィールドを設定
        .PivotFields("新規追加日").Orientation = xlDataField

        'プログラム9｜行フィールドを設定
        With .PivotFields("新規追加日")
            .Orientation = xlPageField
        End With

        'プログラム10｜行フィールドを設定
        With .PivotFields("20年度売上完了、連絡用")
            .Orientation = xlPageField
        End With
    End With

    'プログラム11｜ピボットテーブルの表示形式を変更
    With pt
        .RowAxisLayout xlTabularRow
        .ColumnGrand = False
        .RowGrand = False
        .HasAutoFormat = False
        .RepeatAllLabels xlRepeatLabels
        .NullString = 0
    End With

    With ActiveSheet.PivotTables("pivot1")
        .DisplayErrorString = True
        .NullString = ""
    End With

    ActiveSheet.PivotTables("pivot1").HasAutoFormat = True

  Dim itm As PivotItem, itm2 As PivotItem, buf As String
  Set ws = Sheets("当日件数")
  buf = Format(Date, "m/d/yyyy")

  For Each itm In ws.PivotTables("pivot1") _
    .PivotFields("新規追加日").PivotItems
      Select Case itm.Value
        Case buf
          itm.Visible = True
        Case Else
          itm.Visible = False
      End Select
  Next itm
’----------------------------------------------------------
  MaxRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
  MaxCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
  ws.Range(Cells(4, 1), Cells(MaxRow, MaxCol)).Copy
★コピーした範囲をメールの【新規】の後に貼り付けしたい
’----------------------------------------------------------
  Dim itm2 As PivotItem
  For Each itm2 In ws.PivotTables("pivot1") _
    .PivotFields("変更").PivotItems
      Select Case itm2.Value
        Case "追加"
          itm2.Visible = True
        Case Else
          itm2.Visible = False
      End Select
  Next itm2
’----------------------------------------------------------
  Maxrow2 = ws.Cells(Rows.Count, 1).End(xlUp).Row
  MaxCol2 = ws.Cells(1, Columns.Count).End(xlToLeft).Column
  ws.Range(Cells(4, 1), Cells(Maxrow2, MaxCol2)).Copy
★コピーした範囲をメールの【変更】の後に貼り付けしたい
’----------------------------------------------------------

  Dim objOutlook As Outlook.Application
  Dim objMail As Outlook.MailItem
  Dim wsMail As Worksheet

  Set objOutlook = New Outlook.Application
  Set wsMail = ThisWorkbook.Sheets("当日件数")

  Set objMail = objOutlook.CreateItem(olMailItem)

  With wsMail
    objMail.To = "XXX@aaa.com"
    objMail.Subject = "Format(Date, "m/d") & "完了"
    objMail.BodyFormat = olFormatHTML
    objMail.Body = "各位" & vbCrLf & "お疲れ様です。●●です。" & vbCrLf & vbCrLf _
      & "本日新規分完了しました。& vbCrLf & "以下に詳細を追記します。" & vbCrLf & vbCrLf & "【新規】" & vbCrLf & vbCrLf & vbCrLf & "【変更】" & _
        vbCrLf & vbCrLf & vbCrLf & "●●"     'メール本文
    objMail.Display
  End With

  Set objOutlook = Nothing

End sub

＜使用 Excel：Office365、使用 OS：Windows10 ＞

Outlookを用いたマクロの集積として有名なサイトとしてOutlook研究所というサイトがあります。
そのなかの下記の記事を参考にしてみてはどうでしょうか。
"Excel のデータを Outlook の本文に表としてコピーするマクロ"
https://outlooklab.wordpress.com/2019/09/07/excel-%e3%81%ae%e3%83%87%e3%83%bc%e3%82%bf%e3%82%92-outlook-%e3%81%ae%e6%9c%ac%e6%96%87%e3%81%ab%e8%a1%a8%e3%81%a8%e3%81%97%e3%81%a6%e3%82%b3%e3%83%94%e3%83%bc%e3%81%99%e3%82%8b%e3%83%9e%e3%82%af/

# 私見ですが、こうした情報は、添付ファイルで受け渡すほうが、
# 双方にとって有益だとは思います。
（γ） 2021/11/26(金) 21:08

コメント返信：

[ 一覧(最新更新順) ]

[[20211126195810]] 『Outlookメール本文にExcelの表を貼り付ける方法』（dokom） ページの最後に飛ぶ

[[20211126195810]]　『Outlookメール本文にExcelの表を貼り付ける方法』（dokom）　ページの最後に飛ぶ