VBAでOutlookの受信メールフォルダから特定のメールの情報を抽出しExcelへ転記する ※この記事は個人的な備忘録です

はじめに

• この記事は個人的な備忘録です。
• 業務で使用するためのサンプルツール用のコードなどを記述します。書きかけのコードもあります。
• あくまでサンプルのため、コードの実践は自己責任でお願いします。

概要

まずはOutlookの参照設定をする

そして、マクロ記述してテストする

まずはどれくらい時間がかかるのかをチェックする

Option Base 1

Enum Header_
    件名 = 1
    担当者
    添付ファイル名
End Enum

Sub メール内容抽出転記()

    Dim appOL As Outlook.Application
    Set appOL = New Outlook.Application
    
    '受信トレイのメールをすべて抽出
    Dim objItems As Object
    Set objItems = appOL.GetNamespace("MAPI").GetDefaultFolder(6).Items
    
    Dim objMailItem As Object
    Dim arr() As String
    Dim txt As String
    
        Dim i As Long
    i = 1
    For Each objMailItem In objItems
    
        With objMailItem
            If .Subject Like "*抽出のトリガー（件名）*" Then
                txt = .Body
                ReDim Preserve arr(2, i)
                arr(Header_.件名, i) = .Subject
                arr(Header_.担当者, i) = Mid(txt, InStr(txt, "抽出のトリガー（本文）") + 8, 2)
                i = i + 1
            End If
        End With
    
    Next objMailItem
    
    Dim arr2 As Variant
    arr2 = WorksheetFunction.Transpose(arr)
    
    With Sheet4
      .Range(.Cells(1, 1), .Cells(UBound(arr2, 1), UBound(arr2, 2))) = arr2
    End With

End Sub

Option Base 1

Enum Header_
    受信日時 = 1
    件名
    担当者
End Enum



Sub メール内容抽出転記2()

   Dim appOL As Outlook.Application
   Set appOL = New Outlook.Application
    
 '   '受信トレイのメールをすべて抽出
    Dim objItems As Object
     Set objItems = appOL.GetNamespace("MAPI").GetDefaultFolder(6).Items
    
    Dim objMailItem As Object
    Dim arr() As String
    Dim txt As String
    
        Dim i As Long
    i = 1
    For Each objMailItem In objItems
    
        With objMailItem
    '        If .Subject Like "*1234*" Then
            If .Subject Like "*1234*" And .ReceivedTime Like "*2021/09*" Then
                txt = .Body
                ReDim Preserve arr(3, i)
                arr(Header_.受信日時, i) = .ReceivedTime
                arr(Header_.件名, i) = .Subject
                arr(Header_.担当者, i) = Mid(txt, InStr(txt, "12345678") + 8, 2)
                i = i + 1
            End If
        End With

   Next objMailItem
    
    Dim arr2 As Variant
    arr2 = WorksheetFunction.Transpose(arr)
    
    With Sheet1
      .Range(.Cells(1, 1), .Cells(UBound(arr2, 1), UBound(arr2, 2))) = arr2
    End With

End Sub