受信したメールに添付された Excel ファイルをもとに別の Excel ファイルの内容を更新するマクロ


コメントにて以下のご要望をいただきました。


お世話になります。
いつも当該サイトのコードを参考して頂いており、大変感謝致します。
さて、最近下記の様な自動処理マクロを考えておりますが、ご協力を頂きたくお願い致します。
使用環境は Windows 7, Office Pro Plus 2010
毎日倉庫より納品された貨物の実寸報告のメールが数回に受信されます。
そのメールには、商品番号と商品梱包の三辺サイズが記載されたEXCELファイルが添付されております。
件名:サイズ報告
(EXCELファイルの例:)
A列 B列 C列 D列
品番1 幅1 横1 高1
品番2 幅2 横2 高2
そのメールが受信されましたら、自動的に商品マスターファイル(excel形式)の該当商品のサイズを
更新するよう、とのマクロを考えております。  
受信したEXCELファイルを一旦保存し、その後 EXCEL側でVBA処理するなら、
特に問題なくできましたが、OUTLOOK側で自動的処理するできるなら大変助かります。
何卒、アドバイスを頂けますようお願い致します。


メールが受信された際に何らかの自動処理を行うには Application オブジェクトの NewMailEx イベントを使用します。
そして、NewMailEx イベントの EntryIDCollection には受信したアイテムのエントリー ID が格納されていますので、これを引数として Session.GetItemFromID メソッドにより受信したメール アイテムを取得できます。
メール アイテムの添付ファイルを取得するには Attachments プロパティを使用し、Attachment オブジェクトの SaveAsFile メソッドでローカルに保存します。
保存した Excel ファイルで何か処理をする手順は Excel のマクロの記述と同じです。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objMail As Object
     ' 受信したアイテムを取得
     Set objMail = Session.GetItemFromID(EntryIDCollection)
     ' アイテムがメールであり、件名が "サイズ報告" なら処理を開始
     If TypeName(objMail) = "MailItem" And objMail.Subject = "サイズ報告" Then
         ReplaceMaster objMail
     End If
End Sub
' マスター ファイルを更新するサブ
Private Sub ReplaceMaster(ByVal objMail As MailItem)
     ' 商品マスター ファイルのフルパス
     Const MASTER_FILE = "c:\temp\master.xlsx"
     ' 添付ファイルを一時保存するフォルダー (最後に \ を付ける)
     Const TEMP_FOLDER = "c:\temp\"
     ' マスター ファイルの先頭行には列名が入っていると仮定
     Const START_ROW_MASTER = 2
     ' サイズ報告のファイルは 1 行目からデータと仮定
     Const START_ROW_REPORT = 1
     '
     Dim objAttach As Attachment
     Dim strReportXls As String
     Dim wbMaster As Object ' Excel.Workbook
     Dim wsMaster As Object ' Excel.Worksheet
     Dim wbReport As Object ' Excel.Workbook
     Dim wsReport As Object ' Excel.Worksheet
     Dim i As Integer
     Dim iRow As Integer
     ' 添付ファイルがなければ処理を中断
     If objMail.Attachments.Count = 0 Then
         Exit Sub
     End If
     ' 添付ファイルを取得
     Set objAttach = objMail.Attachments(1)
     With objAttach
         ' 添付ファイルが Excel ファイルなら一時フォルダーに保存
         If .FileName Like "*.xls" Or .FileName Like "*.xls?" Then
             strReportXls = TEMP_FOLDER & .FileName
             .SaveAsFile strReportXls
         Else
             ' 添付ファイルが Excel ファイルでなければ中断
             Exit Sub
         End If
     End With
     ' マスター ファイルを取得
     Set wbMaster = GetObject(MASTER_FILE)
     wbMaster.Windows(1).Activate
     Set wsMaster = wbMaster.Sheets(1)
     ' 一時ファイルを取得
     Set wbReport = GetObject(strReportXls)
     Set wsReport = wbReport.Sheets(1)
     '
     i = START_ROW_REPORT
     ' 一時ファイルの 1 列目 (品番) にデータがなくなるまで繰り返し
     While wsReport.Cells(i, 1) <> ""
         iRow = START_ROW_MASTER
         With wsMaster
             ' マスター ファイルの 1 列目 (品番) にデータがなくなるか、
             ' 一時ファイルの 1 列目と一致するまで繰り返し
             While .Cells(iRow, 1) <> "" And _
                   .Cells(iRow, 1) <> wsReport.Cells(i, 1)
                 ' 次の行に移動
                 iRow = iRow + 1
             Wend
             ' 品番が一致したら置き換え
             If .Cells(iRow, 1) <> "" Then
                 .Cells(iRow, 2) = wsReport.Cells(i, 2)
                 .Cells(iRow, 3) = wsReport.Cells(i, 3)
                 .Cells(iRow, 4) = wsReport.Cells(i, 4)
             End If
         End With
         ' 次の行に移動
         i = i + 1
     Wend
     ' 一時ファイルは保存せずに閉じる
     wbReport.Close False
     ' マスター ファイルは保存して閉じる
     wbMaster.Close True
     ' 一時ファイルを削除する
     Kill strReportXls
End Sub

マクロの登録方法やメニューへの追加について

広告

受信したメールに添付された Excel ファイルをもとに別の Excel ファイルの内容を更新するマクロ」への2件のフィードバック

  1. お世話になります
    翌日のメンバーリストを添付エクセルファイルで受け取ったら、添付ファイルのシートをマスターファイルのシートへコピーペーストして、下記のようなマクロを走らせてリストを基に印刷をするマクロをくみたいのですが、、OUTLOOKマクロでメール受け取り、保存からエクセルへ転記 、自動印刷という流れが私の知識ではわかりませんでした、、、お力をお貸し願えませんでしょうか、、、

    エクセルの方の リストのあるシートから別シートの日報を印刷するマクロ(氏名と日付と登録番号を差し込み印刷)は下記のようなものです。

    Sub Macro1()

    ‘ Macro1 Macro

    Workbooks.Open Filename:= _
    “C:\temp\スタッフメンバー表.xls”

    Workbooks.Open Filename:= _
    “C:temp\リストに合わせて出力.xlsm” _
    , UpdateLinks:=0

    Windows(“スタッフメンバー表.xls”).Activate
    Cells.Select
    Selection.Copy
    Windows(“ギルドリストに合わせて出力.xlsm”).Activate
    Cells.Select
    ActiveSheet.Paste

    Windows(“リストに合わせて出力.xlsm”).Activate

    ‘まず参加者リストワークシートのセルB6をアクティブセルにする
    Range(“C5”).Select

    ‘ループXの開始
    Do

    ‘アクティブセルを1つ下に移動する
    ActiveCell.Offset(1, 0).Select

    ‘空欄であれば、プログラムを終了する
    ‘Trim関数は前後のスペースを消去する
    If Trim(ActiveCell.Value) = “” Then
    Exit Do
    End If

    ‘非表示セルは印刷の対象としない
    If ActiveCell.EntireRow.Hidden = False Then

    ‘これ以降、すべて作成元シート
    With Worksheets(“作成元”)

    ‘レコードの先頭セルを選択
    .Range(“Q1”).Value = ActiveCell.Offset(0, 0).Value

    ‘レコードの最終セルであれば、1部印刷を実行する
    .PrintOut

    ‘印刷用シート終了
    End With

    End If

    ‘ループXの終了
    Loop

    ‘画面のちらつきを防止する
    Application.ScreenUpdating = True
    End Sub

  2. 1)毎日 翌日の出勤予定スタッフリスト(添付エクセルファイル)がメールで送付されます
    2) 添付エクセルファイルの1つ目のシートを全コピー
    3) C:\Users\Downloads にあるマスターファイルの”sheet1″へペースト 
    4) マスターファイルに入っているマクロ(ペーストしたリストから差し込み印刷)を実行
    5) マスターファイル保存後 閉じる

    という流れのマクロを組みたく、いろいろ検索し下記の様なルールからのスクリプト実行のコードにはたどり着き、マスターファイルを開くところまではなんとかなったのですが、添付ファイルからコピーペースト、その後マスターファイルのマクロを実行、が行えません、、お力をお貸しください、よろしくお願い致します。

    Sub CopyAttachmentToExcel(olitem As Outlook.MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlTempWB As Object
    Dim xlSheet As Object
    Dim xlTempSheet As Object
    Dim lngTempLast As Integer
    Dim lngLast As Integer
    Dim strFname As String
    Dim strTempPath As String
    Dim bXLStarted As Boolean

    Const strPath As String = “C:\Users\Downloads\master_file.xlsm” ‘ローカルのマスターファイルのパス
    strTempPath = Left(strPath, InStrRev(strPath, “C:\Users\Downloads\”)) ‘一時保存のためのパス

    On Error Resume Next
    Set xlApp = GetObject(, “Excel.Application”)
    If Err 0 Then
    Set xlApp = CreateObject(“Excel.Application”)
    bXLStarted = True
    End If
    xlApp.Visible = True

    On Error GoTo 0
    ‘ワークブックに入力の為ファイル開く
    Set xlWB = xlApp.Workbooks.Open(strPath)
    Set xlSheet = xlWB.Sheets(“Sheet1”) ‘The sheet in the local workbook

    ‘添付ファイル開く
    With olitem.Attachments.item(1)
    If Right(.DisplayName, 4) = “xls” Then
    lngLast = xlSheet.Range(“A” & xlSheet.Rows.Count).End(-4162).Row
    strFname = strTempPath & .DisplayName
    .SaveAsFile strFname
    Set xlTempWB = xlApp.Workbooks.Open(strFname, editable:=True)
    Set xlTempSheet = xlTempWB.Sheets(“DATA”)
    lngTempLast = xlTempSheet.Range(“B” & xlTempSheet.Rows.Count).End(-4162).Row
    xlSheet.Range(“A” & lngLast + 1, “S” & lngLast + lngTempLast – 1).Value = xlTempSheet.Range(“A2”, “S” & lngTempLast).Value
    xlWB.Save
    End If

    End With
    xlWB.Close SaveChanges:=True
    xlTempWB.Close SaveChanges:=False
    If bXLStarted Then
    xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set xlTempWB = Nothing
    Set xlTempSheet = Nothing
    Set olitem = Nothing
    End Sub

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト /  変更 )

Google フォト

Google アカウントを使ってコメントしています。 ログアウト /  変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト /  変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト /  変更 )

%s と連携中