以前の記事でサブフォルダのメールを取り込む方法を紹介しました。
OutlookのメールをExcelに取り込む サブフォルダ対応
この方法だと、メール取り込む場合、皆さんに同じ場所に同じ名前のフォルダを作ってもらわなければいけなくなります。
また、フォルダを変更したい場合はＶＢＡをいじってフォルダ名を変更しないといけないんですよね。
しかし、我が部署にＶＢＡいじれる人なんてほとんどいない！
その度に出動するのはちょっと面倒……。
なんとか対処せねば！
という事で。
またまた色々なサイトを参考にさせていただき、発展させたのが今回のもの。
「受信トレイに、
↓
「Excelに読み込む用のフォルダを作っておいてね。」
と、フォルダ名の指定をなくすことに成功しました！
また、念のためフォルダの階層が増えても大丈夫なように対応しておくことにしました。
例）Outlookの「私の名前のアカウント」内の、「
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 | 件名 | 本文 |
- 少し離れたところにフォルダ名の入力欄を作成
| AA | AB | AC | AD | |
|---|---|---|---|---|
| 1 | ｱｶｳﾝﾄ名 ※必須 |
親ﾌｫﾙﾀﾞ名 ※必須 |
子ﾌｫﾙﾀﾞ名 | 孫ﾌｫﾙﾀﾞ名 |
| 2 | ×××@×××.jp | 受信トレイ | 申込書 | 取り込み用 |
アカウント名は〇〇@〇〇.jpに届いたメールを取り込むなら、〇〇@〇〇.jpを入れればOKです。
ＶＢＡ
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 Dim StrA As String Dim StrB As String Dim StrC As String Dim StrD As String ' 「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") ' 指定フォルダの名前の入っている場所 StrA = Worksheets("リスト").Range("AA2").Value ' アカウント名 StrB = Worksheets("リスト").Range("AB2").Value ' 親フォルダ名 StrC = Worksheets("リスト").Range("AC2").Value ' 子フォルダ名 StrD = Worksheets("リスト").Range("AD2").Value ' 孫フォルダ名 ' Outlookの指定フォルダのメールを最終行の１行下に取得・件数分繰り返す '分岐--------------------------------------------------- ' Ａ・子フォルダ名も孫フォルダ名も空欄なら親フォルダを読み込む If Range("AC2") = "" And Range("AD2") = "" Then For Each itms1 In objNAMESPC.Folders(StrA).Folders(StrB).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 ' Ｂ・孫フォルダ名が空欄なら子フォルダを読み込む ElseIf Range("AD2") = "" Then For Each itms1 In objNAMESPC.Folders(StrA).Folders(StrB).Folders(StrC).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 ' Ｃ・孫フォルダを読み込む Else For Each itms1 In objNAMESPC.Folders(StrA).Folders(StrB).Folders(StrC).Folders(StrD).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 End If '------------------------------------分岐ここまで ' セットしていた条件を解除 Set objOL = Nothing Set sht = Nothing Set objNAMESPC = Nothing Range("A1").Select ' 画面更新停止を解除 Application.ScreenUpdating = True ' 終了メッセージ MsgBox "終了しました。" End Sub
※シート名・アカウント名・フォルダ名は各自設定しているものに変更してください。
※親フォルダは受信トレイ以外でも取り込めます。
これで、一行目の題名の下に指定したフォルダ内のメールがすべて取り込まれます。
