40歳からExcelに挑戦!

OutlookのメールをExcelに取り込む


こんばんは。雪ん子です。
お越しいただきありがとうございます。

このブログはExcelやAccessの備忘録です。

初心者なので、変なコードとか出てくるかもしれません( ノД`)
もっと良い方法があったら、どしどしコメント下さいね。

f:id:snow0303:20190311203619j:plain



現在、メールで送られてきた内容の一部を、ひたすらコピー&ペーストで対応している業務があるのです。

他の同僚は普通にこなしているのですが、飽き性な私はイヤで仕方ない。

で、思い付いてしまいました。

「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に取り込む 色々なフォルダに対応