Excel VBA | 複数ブックにまたがって条件付きでピボットグラフをメール添付して送信する

VBA
2011.03.09
スポンサーリンク

ここでは 複数ブックにまたがって条件付きでピボットグラフをメール添付して送信する VBA の例を紹介します。ポイントは「複数ブックをループして条件に合致するピボットテーブルを探し、そのグラフを一時的に画像やPDFに保存し、Outlookを使ってメールに添付して送信する」ことです。

⚠️ 注意：この処理は Outlook がインストールされている環境で動作します。実行前に必ずバックアップを取りましょう。

基本例：数量・売上ピボットをPDF化してメール送信

Sub 複数ブックでピボットグラフをメール送信()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim pt As PivotTable
    Dim chartObj As ChartObject
    Dim pdfPath As String
    Dim OutApp As Object
    Dim OutMail As Object
    
    ' Outlook起動
    Set OutApp = CreateObject("Outlook.Application")
    
    For Each wb In Application.Workbooks
        If wb.Name <> ThisWorkbook.Name Then
            For Each ws In wb.Worksheets
                ' 条件：シート名が「Data」
                If ws.Name = "Data" Then
                    For Each pt In ws.PivotTables
                        If InStr(pt.Name, "数量") > 0 Or InStr(pt.Name, "売上") > 0 Then
                            ' グラフ作成
                            Set chartObj = ws.ChartObjects.Add(Left:=300, Top:=50, Width:=400, Height:=300)
                            chartObj.Chart.SetSourceData Source:=pt.TableRange2
                            chartObj.Chart.ChartType = xlColumnClustered
                            chartObj.Chart.HasTitle = True
                            chartObj.Chart.ChartTitle.Text = pt.Name & " グラフ"
                            
                            ' PDF保存
                            pdfPath = Environ("TEMP") & "\" & ws.Name & "_" & pt.Name & ".pdf"
                            chartObj.Chart.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath
                            
                            ' メール作成
                            Set OutMail = OutApp.CreateItem(0)
                            With OutMail
                                .To = "recipient@example.com"
                                .Subject = "ピボットグラフ送付: " & pt.Name
                                .Body = "添付のピボットグラフをご確認ください。"
                                .Attachments.Add pdfPath
                                .Send
                            End With
                            
                            chartObj.Delete
                        End If
                    Next pt
                End If
            Next ws
        End If
    Next wb
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
VB

👉 開いているすべてのブックから「Data」シートにある 数量ピボット と 売上ピボット をグラフ化 → PDF化 → Outlookメールに添付して送信します。

応用例1：セルの値で判定して画像添付

Sub セル値でピボットグラフ画像送信()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim pt As PivotTable
    Dim chartObj As ChartObject
    Dim imgPath As String
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    
    For Each wb In Application.Workbooks
        For Each ws In wb.Worksheets
            ' A1セルが「送信」と書かれていたら対象
            If ws.Range("A1").Value = "送信" Then
                For Each pt In ws.PivotTables
                    Set chartObj = ws.ChartObjects.Add(Left:=300, Top:=50, Width:=400, Height:=300)
                    chartObj.Chart.SetSourceData Source:=pt.TableRange2
                    chartObj.Chart.ChartType = xlPie
                    chartObj.Chart.HasTitle = True
                    chartObj.Chart.ChartTitle.Text = pt.Name & " グラフ"
                    
                    ' PNG保存
                    imgPath = Environ("TEMP") & "\" & ws.Name & "_" & pt.Name & ".png"
                    chartObj.Chart.Export Filename:=imgPath, FilterName:="PNG"
                    
                    ' メール送信
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = "recipient@example.com"
                        .Subject = "ピボットグラフ送付: " & pt.Name
                        .Body = "添付のピボットグラフをご確認ください。"
                        .Attachments.Add imgPath
                        .Send
                    End With
                    
                    chartObj.Delete
                Next pt
            End If
        Next ws
    Next wb
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
VB

応用例2：複数条件を組み合わせてPDF & PNG同時送信

Sub 複数条件でピボットグラフ送信()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim pt As PivotTable
    Dim chartObj As ChartObject
    Dim pdfPath As String, imgPath As String
    Dim OutApp As Object, OutMail As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    
    For Each wb In Application.Workbooks
        For Each ws In wb.Worksheets
            ' 条件1: シート名が「Sales」で始まる
            ' 条件2: B2セルが100以上
            If Left(ws.Name, 5) = "Sales" And ws.Range("B2").Value >= 100 Then
                For Each pt In ws.PivotTables
                    If InStr(pt.Name, "数量") > 0 Or InStr(pt.Name, "売上") > 0 Then
                        Set chartObj = ws.ChartObjects.Add(Left:=300, Top:=50, Width:=400, Height:=300)
                        chartObj.Chart.SetSourceData Source:=pt.TableRange2
                        chartObj.Chart.ChartType = xlLine
                        chartObj.Chart.HasTitle = True
                        chartObj.Chart.ChartTitle.Text = pt.Name & " グラフ"
                        
                        ' PDF保存
                        pdfPath = Environ("TEMP") & "\" & ws.Name & "_" & pt.Name & ".pdf"
                        chartObj.Chart.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath
                        
                        ' PNG保存
                        imgPath = Environ("TEMP") & "\" & ws.Name & "_" & pt.Name & ".png"
                        chartObj.Chart.Export Filename:=imgPath, FilterName:="PNG"
                        
                        ' メール送信
                        Set OutMail = OutApp.CreateItem(0)
                        With OutMail
                            .To = "recipient@example.com"
                            .Subject = "ピボットグラフ送付: " & pt.Name
                            .Body = "添付のピボットグラフをご確認ください。"
                            .Attachments.Add pdfPath
                            .Attachments.Add imgPath
                            .Send
                        End With
                        
                        chartObj.Delete
                    End If
                Next pt
            End If
        Next ws
    Next wb
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
VB

ポイント

  • PDF出力 → Chart.ExportAsFixedFormat Type:=xlTypePDF
  • 画像出力 → Chart.Export Filename:=..., FilterName:="PNG"
  • Outlookメール送信 → CreateObject("Outlook.Application") → .Attachments.Add
  • 複数条件を組み合わせ → シート名やセル値で対象を絞り込み

練習課題

  1. 全ブックの「Sheet2」にあるピボットグラフを PDF にしてメール送信するコードを書いてみる
  2. 各シートのC1セルが「Send」と書かれていたらピボットグラフを PNG 添付して送信するコードを作る
  3. 複数条件を組み合わせて「シート名がReportで始まり、A1セルが空でないなら数量・売上ピボットを PDF と PNG 両方添付して送信する」コードを作る

こうした仕組みを作ると、複数ブックにまたがって条件付きでピボットグラフをメール添付して送信する自動化ツールが完成します。

VBA
スポンサーリンク
シェアする
@lifehackerをフォローする
スポンサーリンク
@lifehacker
スポンサーリンク
タイトルとURLをコピーしました