現在、メールで送られてきた内容の一部を、ひたすらコピー&ペーストで対応している業務があるのです。
他の同僚は普通にこなしているのですが、飽き性な私はイヤで仕方ない。
で、思い付いてしまいました。
「OutlookのメールをExcelに一気に取り込めたら、ものすごく楽になるじゃん!」
先輩に相談したら、大賛成してくれました。
話が聞こえていた他の方も
「そうなったら良いね!」
と。
しかし、我がグループにはそれを形にできる人が誰もいない(笑)
でも、期待させてしまったので、やるしかありません!
言い出しっぺですから。
てことで、Yahoo! 知恵袋とか色々な方のblogとかをひたすら拝見。
最近マクロを覚えたばかりの私には果てしない道のりで、
「う"~」
と唸ったり、
「いや、そうじゃないんだって……」
と嘆いたり。
紆余曲折ありましたが、なんとか完成。
(諦めの悪い性格で本当によかった。)
知恵袋やブログで教えて下さっている皆さん、本当にありがとうございました。
そして、唸ったり嘆き続けてうるさかったのに、我慢してくれた近くの席の仲間に感謝。
OutlookのメールをExcelに取り込む
受信ボックスのメールを一括で取り込みます。
私の設定
- VBA画面のツール→参照設定
Visual Basic For Applications
Microsoft Excel 15.0 Object Library
OLE Automation
Microsoft Office 15.0 Object Library
の4つにチェック。
- シート名を「リスト」に。
- 一行目に題名
A | B | C | D | E | F | |
---|---|---|---|---|---|---|
1 | 受信日時 | 差出人 | 差出人 アドレス |
CC | 件名 | 本文 |
VBA
Public Sub 受信メール() '画面更新停止 Application.ScreenUpdating = False ' 定義 Dim objOL As Object Dim sht As Worksheet Dim rowCnt As Long Dim itms As Variant ' 「Outlookから取得する」をobjOLと命名 Set objOL = CreateObject("Outlook.Application") ' 読み込むシート(シート名リスト)をshtと命名 Set sht = Worksheets("リスト") ' シート名 ' A列一番下のセルをrowCntと命名 rowCnt = Cells(Rows.Count, "A").End(xlUp).Row ' Outlookの受信ボックスのメールを最終行の1行下に取得・件数分繰り返す For Each itms In objOL.GetNamespace("MAPI").GetDefaultFolder(6).Items ' olFolderInbox:6 If itms.Class = 43 Then ' olMail:43 sht.Cells(rowCnt + 1, 1).Value = itms.ReceivedTime ' A列・受信日時 sht.Cells(rowCnt + 1, 2).Value = itms.SenderName ' B列・差出人 sht.Cells(rowCnt + 1, 3).Value = itms.SenderEmailAddress ' C列・差出人アドレス sht.Cells(rowCnt + 1, 4).Value = itms.CC ' D列・CC sht.Cells(rowCnt + 1, 5).Value = itms.Subject ' E列・件名 sht.Cells(rowCnt + 1, 6).Value = itms.Body ' F列・本文 rowCnt = Cells(Rows.Count, "A").End(xlUp).Row End If Next Set objOL = Nothing Range("A1").Select ' 画面更新停止を解除 Application.ScreenUpdating = True ' 終了メッセージ MsgBox "終了しました。" End Sub
※シート名は各自設定しているものに変更してください。
サブフォルダを取り込みたい方はこちらを参考にしてください。
OutlookのメールをExcelに取り込む_サブフォルダ対応
OutlookのメールをExcelに取り込む 色々なフォルダに対応