Regex to extract amounts from Outlook email body

Question

I have an email that comes into a shared folder every day, and I'm trying to extract specific values out of the email. There's some text, and then two dollar amounts that I need to pull out.

Here's the email, with what I need highlighted in Group1 https://regex101.com/r/5YOJnG/20

I have been able to select the folder, and was able to pull the body of the email I want out. Actually pulling the specific number out of the body of the email has been a challenge, though. I've gotten regex101 to get Group 1 to match my desired output, but haven't been able to translate that into successful code.

Here is my code - MyAr (24) and MyAr(32) print the correct numbers - 10,706,855.69 and (10,365,481.96) - but the regex returns 70 at the moment.

Option Explicit

Sub OutlookTesting()

Dim y As Workbook
Dim folder As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olfldr As Outlook.MAPIFolder
Dim sharedemail As Outlook.Recipient
Dim olMail As Variant
Dim myTasks As Outlook.Items
Dim MyAr() As String
Dim i As Long
Dim regEx As Object
Dim tester As Variant
Dim Pattern1 As String

Set y = Workbooks.Open("C:\Users\Sam.Givens\OneDrive - Motiva Enterprises LLC\Desktop\VBA Forecast.xlsm")
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set sharedemail = olNS.CreateRecipient("MOTIVA-Forecasting@motiva.com")
Set olfldr = olNS.GetSharedDefaultFolder(sharedemail, olFolderInbox)
Set folder = olfldr
Set myTasks = folder.Items

myTasks.Sort "Subject"

i = 1

For Each olMail In myTasks
    If InStr(olMail.Subject, "Retail Cash Forecast 09/30/2020") > 0 Then
        MyAr = Split(olMail.Body, vbCrLf)
        Debug.Print (MyAr(24))
        Debug.Print (MyAr(32))
        Pattern1 = "^[0-9.,()]*$"
        Set regEx = CreateObject("VBScript.RegExp")
        For i = LBound(MyAr) To UBound(MyAr)
            With regEx
                .Global = True
                .MultiLine = True
                .IgnoreCase = False
                .pattern = Pattern1
                Set tester = .Execute(i)
            End With
        Next i
        i = i + 1
    End If
Next olMail

Debug.Print (tester(0))

Set olfldr = Nothing
Set olNS = Nothing
Set olApp = Nothing

End Sub

Edit with working code:

Option Explicit

Sub OutlookTesting()

Dim y As Workbook
Dim folder As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olfldr As Outlook.MAPIFolder
Dim sharedemail As Outlook.Recipient
Dim olMail As Variant
Dim myTasks As Outlook.Items
Dim regEx As Object
Dim Matches As Variant
Dim Matches2 As Variant
Dim Pattern1 As String
Dim Pattern2 As String
Dim BodyText

Set y = Workbooks.Open("")
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set sharedemail = olNS.CreateRecipient("")
Set olfldr = olNS.GetSharedDefaultFolder(sharedemail, olFolderInbox)
Set folder = olfldr
Set myTasks = folder.Items

myTasks.Sort "Subject"

For Each olMail In myTasks
    If InStr(olMail.Subject, "") > 0 Then
        BodyText = olMail.Body
        Pattern1 = "\bCredit\s*\d*\s+\(([0-9,.]*)"
        Pattern2 = "\bDebit\s*\d*\s+([0-9,.]*)"
        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
            .Global = True
            .pattern = Pattern1
            If .Test(BodyText) Then
                Set Matches = .Execute(BodyText)
            End If
        End With
        With regEx
            .Global = True
            .pattern = Pattern2
            If .Test(BodyText) Then
                Set Matches2 = .Execute(BodyText)
            End If
        End With
    End If
Next olMail
Debug.Print (Matches(0).submatches(0))
Debug.Print (Matches2(0).submatches(0))

Set olfldr = Nothing
Set olNS = Nothing
Set olApp = Nothing

End Sub

user_9601310 · Answer

I think your approach is perhaps a little off target. I've looked at your example at regex101.com and come up with an alternate section of code as below. This is VBScript but apart from the "Set re ..." line as noted, it should run unchanged in VBA. I'm sure you can adapt it to suit your context :-).

As far as I can determine, you don't need to split the message text into separate lines and use a loop as you are doing (and yes, your Debug.Print is in the wrong place!). Both the debit and credit amounts can be captured in a single regex test, but because the match is across different lines, it needs the [\s\S]* included in the pattern. (Note that the "Multiline" setting somewhat counterintuitively is irrelevant for this).

Dim BodyText
Dim Pat
Dim re
Dim Matches
Pat = "\bDebit\s*\d*\s+([0-9,.]*)\sUSD[\s\S]*Credit\s\d+\s$([0-9,.]*)$\sUSD"
'-- Pat1 = "\bCredit\s*\d*\s+$([0-9,.]*)$"
'-- Pat2 = "\bDebit\s*\d*\s+([0-9,.]*)"

           'vvvvvvv Assign your olMail.Body to BodyText here
BodyText = "Hello," & vbCrLf  & vbCrLf & _
    "Please release. " & vbCrLf & _ 
    "Please find below the retail cash forecast that will be drafted xx/xx/xxxx."  & vbCrLf  & _
    " RUN ID    No. Amount                          Curr." & vbCrLf & _
    "xxxxx - Direct Debit   13  10,706,855.69   USD" & vbCrLf & _
    "xxxxx - Direct Credit  213122  (10,365,481.96) USD"  & vbCrLf & _
    "TOTAL      341,373.73  USD"
Set re = New RegExp  '-- For VBA use Set re = CreateObject("VBScript.RegExp")
With re
    .Global = True
    .Pattern = Pat
    If .Test(BodyText) Then
        Set Matches = .Execute(BodyText)
        MsgBox "Debit = " & Matches.item(0).submatches(0) & vbCrLf & "Credit = " & Matches.item(0).submatches(1), ,"Result"
    Else
        MsgBox "No match", ,"Result"
    End If
End With

Just as an additional note, there are a couple of additional items in the pattern that you may need to adjust. As you may see, it currently checks for USD after the debit and credit amounts. It also checks for brackets i.e. "()" surrounding the credit amount. If these are not relevant, just remove them.

Regex to extract amounts from Outlook email body

1 Answers