OutlookメールからExcelへデータ抽出

シート「マクロ」には、以下の設定が可能になっています。

「マクロ開始」により、以下の処理が実行されます。

Outlookの受信トレイに入っているメールをすべて処理
件名に「メール件名」で設定した名称が入っているメールのみ処理対象
処理したメールは、「フォルダ」で設定したフォルダに移動
シート「リスト」の１行目の項目名の後ろをメールから抽出し、リストに追記

シート「リスト」の結果が以下です。

最初のデータは、以下メールから抽出されています。件名に「受注確認」が含まれています。本文には、1行目の項目名の後の文字を抽出しています。

以下がマクロです。

Sub 受注確認メールを抽出して保存()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olMail As Outlook.MailItem
    Dim xlWorkbook As Excel.Workbook
    Dim xlWorksheet As Excel.Worksheet
    Dim targetFolder As Outlook.MAPIFolder  ' 移動先のフォルダ
    Dim moveFolderName As String            ' 移動先のフォルダ名
    
    ' Outlookアプリケーションを取得
    Set olApp = New Outlook.Application
    ' Outlookの受信トレイを取得
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)
    ' 受信トレイのメールアイテムを取得
    Set olItems = olFolder.Items
    
    ' 移動先のフォルダを指定
    moveFolderName = wsMacro.Range("フォルダ") ' 移動先のフォルダ名
    ' 移動先のフォルダを取得
    On Error Resume Next
    Set targetFolder = olFolder.Parent.Folders(moveFolderName)
    On Error GoTo 0
    
    ' 移動先のフォルダが存在しない場合は作成する
    If targetFolder Is Nothing Then
        Set targetFolder = olFolder.Parent.Folders.Add(moveFolderName)
    End If
    
    Set xlWorkbook = ThisWorkbook
    Set xlWorksheet = xlWorkbook.Sheets("リスト")
    xlWorksheet.Select
    
    Dim メール件名 As String
    メール件名 = wsMacro.Range("メール件名")
    
    Dim row As Long
    ' 行番号を初期化。最後の行。
    row = 2 + xlWorksheet.ListObjects(1).ListRows.Count
    
    Dim clm As Long
    Dim LastClm As Long
    ' 最後の行
    LastClm = xlWorksheet.ListObjects(1).ListColumns.Count
    
    ' 受信トレイのメールをループ処理
    Dim i As Integer
    For i = olItems.Count To 1 Step -1
        Set olMail = olItems(i)
        ' 「メール件名」を確認
        If InStr(olMail.Subject, メール件名) > 0 Then
            ' すべての列
            For clm = 1 To LastClm
                ' メール本文から、リストの項目名の後ろを抽出
                ' 関数GetInfoFromMailで処理
                xlWorksheet.Cells(row, clm).Value = GetInfoFromMail(olMail.Body, Cells(1, clm).Value)
            Next clm

            ' メールを移動
            olMail.Move targetFolder
            
            ' 次の行に移動
            row = row + 1
        End If
    Next i
    
    ' メモリの解放
    Set xlWorksheet = Nothing
    Set xlWorkbook = Nothing
    
    ' Outlookの解放
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Sub

' メール本文mailBodyから、keywordを検索して、その後ろの文字を改行までの文字列を返す。
Function GetInfoFromMail(mailBody As String, keyword As String) As String
    Dim startPos As Long
    Dim endPos As Long
    
    ' キーワードの位置を検索
    startPos = InStr(mailBody, keyword)
    
    ' キーワードが見つかった場合、キーワードの後ろのテキストを取得
    If startPos > 0 Then
        startPos = startPos + Len(keyword)
        endPos = InStr(startPos, mailBody, vbCrLf)
        If endPos = 0 Then
            endPos = Len(mailBody) + 1
        End If
        GetInfoFromMail = Trim(Mid(mailBody, startPos, endPos - startPos))
    Else
        GetInfoFromMail = ""
    End If
End Function

ファイルは、以下からダウンロードしてください。