実は、前回紹介したモノではメインの受信ボックスしか取り込めないんですよね(^_^;)
会社では、Outlookにアカウントが複数登録してあって、更にルールでフォルダ分けしています。
という事で。
またまた色々なサイトを参考にさせていただき、発展させたのが今回のもの。
なんと！
更に発展させることができました！
OutlookのメールをExcelに取り込む 色々なフォルダに対応
Outlookの指定フォルダのメールをExcelに取り込む
指定したフォルダのメールを一括で取り込みます。
私の設定
- VBA画面のツール→参照設定
Visual Basic For Applications
Microsoft Excel 15.0 Object Library
OLE Automation
Microsoft Office 15.0 Object Library
の４つにチェック。
- シート名を「リスト」に。
- 一行目に題名
| A | B | C | D | E | F | |
|---|---|---|---|---|---|---|
| 1 | 受信日時 | 差出人 | 差出人 アドレス |
CC | 件名 | 本文 |
ＶＢＡ
Public Sub 受信メールサブフォルダ() '画面更新停止 Application.ScreenUpdating = False ' 定義 Dim objOL As Object Dim sht As Worksheet Dim rowCnt As Long Dim objNAMESPC As Object Dim itms1 As Variant ' 「Outlookから取得する」をobjOLと命名 Set objOL = CreateObject("Outlook.Application") ' 読み込むシート（シート名リスト）をshtと命名 Set sht = Worksheets("リスト") ' シート名 ' Ａ列一番下のセルをrowCntと命名 rowCnt = Cells(Rows.Count, "A").End(xlUp).Row ' メールの場所をobjNAMESPCと命名 Set objNAMESPC = objOL.GetNamespace("MAPI") ' Outlookの指定フォルダのメールを最終行の１行下に取得・件数分繰り返す For Each itms1 In objNAMESPC.Folders("アカウント名").Folders("受信トレイ").Folders("フォルダ名").Items sht.Cells(rowCnt + 1, 1).Value = itms1.ReceivedTime ' A列・受信日時 sht.Cells(rowCnt + 1, 2).Value = itms1.SenderName ' B列・差出人 sht.Cells(rowCnt + 1, 3).Value = itms1.SenderEmailAddress ' C列・差出人アドレス sht.Cells(rowCnt + 1, 4).Value = itms1.CC ' D列・CC sht.Cells(rowCnt + 1, 5).Value = itms1.Subject ' E列・件名 sht.Cells(rowCnt + 1, 6).Value = itms1.Body ' F列・本文 rowCnt = Cells(Rows.Count, "A").End(xlUp).Row Next ' セットしていた条件を解除 Set objOL = Nothing Set sht = Nothing Set objNAMESPC = Nothing Range("A1").Select ' 画面更新停止を解除 Application.ScreenUpdating = True ' 終了メッセージ MsgBox "終了しました。" End Sub
※シート名・アカウント名・フォルダ名は各自設定しているものに変更してください。
これで、一行目の題名の下にフォルダ内のメールがすべて取り込まれます。
追記
私は処理したメールは他のフォルダに移動させているので、上のＶＢＡで問題がないのですが……
読み込み済みをフォルダ移動させず、新しく届いたメールだけを取り込むようであれば、
この部分を
For Each itms1 In objNAMESPC.Folders("アカウント名").Folders("受信トレイ").Folders("フォルダ名").Items sht.Cells(rowCnt + 1, 1).Value = itms1.ReceivedTime ' A列・受信日時 sht.Cells(rowCnt + 1, 2).Value = itms1.SenderName ' B列・差出人 sht.Cells(rowCnt + 1, 3).Value = itms1.SenderEmailAddress ' C列・差出人アドレス sht.Cells(rowCnt + 1, 4).Value = itms1.CC ' D列・CC sht.Cells(rowCnt + 1, 5).Value = itms1.Subject ' E列・件名 sht.Cells(rowCnt + 1, 6).Value = itms1.Body ' F列・本文 rowCnt = Cells(Rows.Count, "A").End(xlUp).Row Next
このように変更してください。
For Each itms1 In objNAMESPC.Folders("アカウント名").Folders("受信トレイ").Folders("フォルダ名").Items sht.Range("AA1").Value = itms1.ReceivedTime ' AA1に受信日時書き出し Dim rng As Range Set rng = Range("A2:A100").Find(What:=Range("AA1"), LookAt:=xlWhole) ' AA1と同じものをA2～A100で検索 If rng Is Nothing Then ' AA1と同じものが無かったらメールを書き出す sht.Cells(rowCnt + 1, 1).Value = itms1.ReceivedTime ' A列・受信日時 sht.Cells(rowCnt + 1, 2).Value = itms1.SenderName ' B列・差出人 sht.Cells(rowCnt + 1, 3).Value = itms1.SenderEmailAddress ' C列・差出人アドレス sht.Cells(rowCnt + 1, 4).Value = itms1.CC ' D列・CC sht.Cells(rowCnt + 1, 5).Value = itms1.Subject ' E列・件名 sht.Cells(rowCnt + 1, 6).Value = itms1.Body ' F列・本文 rowCnt = Cells(Rows.Count, "A").End(xlUp).Row End If Next
まずは受信日時だけをAA1に書き出す。
時間が記載されているＡ列にAA1と同じ時間があるかを検索して、
同じ受信日時があればメールの書き出しはスキップします。
同じ受信日時がなければメールを書き出します。
判断させる部分は差出人アドレス等、自由に変更して下さい。
差出人アドレスにした場合、
Set rng = Range("A2:A100").Find(What:=Range("AA1"), LookAt:=xlWhole) ' AA1と同じものをA2～A100で検索
のA2:A100を差出人アドレスが入力されている範囲に変更してください。
もちろん範囲はA2:A1000など広げて大丈夫です。
注）
本文で重複しているかはエラーが出て検索できませんでした。
なんでだろ......
勉強がたりませんね。
