【コピペでOK】エクセルにOutlookのメールを出力！VBA(マクロ)コード&DLファイル！

Outlookのメールをエクセルに出力したい！
メールの本文をエクセルでまとめ、集計を行いたい！

Outlookの受信メールをExcelで集計したいとき、手作業での転記は意外と面倒な作業です。特に、本文の集計が必要な場合、コピー＆ペーストするのは非効率ですよね。

そんな時に活躍するのが、メール自動取得VBAです。

今回紹介するコードをコピペするだけで、Outlookの受信フォルダからメールを自動で取得し、Excelに一覧として出力できます。また期間指定機能があるため、受信ボックスに大量のメールが入っている方も、分割して高速で処理が可能です。

「VBAは初めてでよく分からない…」という方でも、そのまま使えるシンプルなコードになっていますので、ぜひ試してみてください！

また、件名などの情報はVBAを使わなくても取得が可能です。VBAを使わない出力方法も解説しているので、そちらも参考にしてみてください。

このブログでは、ほかにもコピペ・ダウンロードで使えるVBAを紹介しています。ぜひほかの記事も参考にしてみてください！

【結論】コピペで使えるメール出力VBA

以下のコードをコピペするだけで、Outlookの受信ボックスに入ったメールを、自動転記できます。

詳しい使用方法は、この後紹介します。

Sub ImportOutlookEmails()
    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Outlook.Namespace
    Dim OutlookFolder As Outlook.MAPIFolder
    Dim OutlookItems As Outlook.Items
    Dim OutlookMail As Outlook.MailItem
    Dim xlWorksheet As Worksheet
    Dim iRow As Integer
    Dim startDate As Date
    Dim endDate As Date
    Dim attachmentStatus As String
    Dim inputStartDate As String, inputEndDate As String

    Application.ScreenUpdating = False

    ' 期間指定のためのダイアログボックスを表示（YYYYMMDD形式）
    inputStartDate = InputBox("取り込むメールの開始日を入力してください（YYYYMMDD形式）")
    inputEndDate = InputBox("取り込むメールの終了日を入力してください（YYYYMMDD形式）")
    
    ' 入力を日付型に変換
    startDate = DateSerial(Left(inputStartDate, 4), Mid(inputStartDate, 5, 2), Right(inputStartDate, 2))
    endDate = DateSerial(Left(inputEndDate, 4), Mid(inputEndDate, 5, 2), Right(inputEndDate, 2))

    ' Outlookのインスタンスを作成
    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    ' 受信トレイのメールを取得
    Set OutlookFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox)

    ' アクティブシートを取得
    Set xlWorksheet = ThisWorkbook.ActiveSheet

    ' 既存データ（2行目以降）を削除
    If xlWorksheet.UsedRange.Rows.Count > 1 Then
        xlWorksheet.Rows("2:" & xlWorksheet.Rows.Count).Delete
    End If

    ' Excelヘッダー行を設定
    xlWorksheet.Cells(1, 1).Value = "送信者"
    xlWorksheet.Cells(1, 2).Value = "件名"
    xlWorksheet.Cells(1, 3).Value = "本文"
    xlWorksheet.Cells(1, 4).Value = "日付"
    xlWorksheet.Cells(1, 5).Value = "添付有無"

    iRow = 2 ' データ行の開始行

    ' Outlookのメールを取得
    Set OutlookItems = OutlookFolder.Items
    OutlookItems.Sort "[ReceivedTime]", True ' 受信日時でソート（新しい順）

    Dim Count As Integer
    Count = 0
    
    For Each Item In OutlookItems
        ' アイテムの型を確認して MailItem の場合のみ処理する
        If TypeOf Item Is Outlook.MailItem Then
            Set OutlookMail = Item  ' 明示的に MailItem にキャスト
            
            ' メールの受信日時が指定された期間内である場合のみ取り込む
            If OutlookMail.ReceivedTime >= startDate And OutlookMail.ReceivedTime <= endDate Then
                ' 添付ファイルの有無を判定
                If OutlookMail.Attachments.Count > 0 Then
                    attachmentStatus = "あり"
                Else
                    attachmentStatus = "なし"
                End If
    
                If OutlookMail.SenderEmailType = "EX" Then
                    ' Exchangeアカウントの場合はSMTPアドレスを取得
                    On Error Resume Next  ' エラー回避（Exchangeアカウントがない場合を考慮）
                    senderEmail = OutlookMail.Sender.GetExchangeUser().PrimarySmtpAddress
                    On Error GoTo 0       ' エラー制御を元に戻す
                Else
                    ' 通常のメールアドレスを取得
                    senderEmail = OutlookMail.SenderEmailAddress
                End If
                    
                ' メールの情報をExcelに書き込む
                xlWorksheet.Cells(iRow, 1).Value = senderEmail
                xlWorksheet.Cells(iRow, 2).Value = OutlookMail.Subject
                xlWorksheet.Cells(iRow, 3).Value = OutlookMail.Body
                xlWorksheet.Cells(iRow, 4).Value = Format(OutlookMail.ReceivedTime, "yyyy/mm/dd")
                xlWorksheet.Cells(iRow, 5).Value = attachmentStatus
    
                iRow = iRow + 1 ' 次の行に移動
                Count = 1
            ElseIf OutlookMail.ReceivedTime <= startDate Or OutlookMail.ReceivedTime >= endDate And Count = 1 Then
                ' 一度期間内に入った後、期間から外れればループから出る
                Exit For
            End If
        End If
    Next Item


    ' メッセージボックスで処理が完了したことを表示
    MsgBox "OutlookのメールをExcelに取り込みました。", vbInformation

    ' オブジェクトを解放
    Set xlWorksheet = Nothing
    Set OutlookItems = Nothing
    Set OutlookFolder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing

    Application.ScreenUpdating = True
    
    Columns("A:E").Select
    Selection.WrapText = False
    Range("A1").Select

End Sub