How can we extract a specific word from an Outlook email message automatically using VBA.

Watch this video on YouTube.

Here’s the complete VBA code:

Option Explicit

Sub GetDataFromOutlook()
‘https://www.exceltrainingvideos.com/get-data-from-outlook-into-excel-worksheet/
Dim OutlookApp As Outlook.Application
‘allows access to all Outlook data stored in the user’s mail stores
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace(“MAPI”)
‘Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders(“Net Sales Report”).Folders(“Sales”)
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox)
i = 1

For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range(“email_Date”).Value Then
Range(“eMail_subject”).Offset(i, 0).Value = OutlookMail.Subject
Range(“eMail_date”).Offset(i, 0).Value = OutlookMail.ReceivedTime
Range(“eMail_sender”).Offset(i, 0).Value = OutlookMail.SenderName
Range(“email_Body”).Offset(i, 0).Value = OutlookMail.Body

i = i + 1
End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

cleanData
usingSplitWithPattern

End Sub

Option Explicit

Sub cleanData()

Dim c As Range

Dim s As String

For Each c In Range(“E3:E5”)

‘Chr(10) is the Line Feed character and Chr(13) is the Carriage Return character
‘https://www.petefreitag.com/item/863.cfm

c = Replace(c, Chr(13) & Chr(10), ” “)

Next c

End Sub

Option Explicit

Sub usingSplitWithPattern()
Dim c As Range
Dim s As String
Dim myArray() As String
Dim i As Long, count As Long
Dim first As Long, last As Long
Dim lengthofarray As Long
Dim x As Long, y As Long

x = 3 ‘row
y = 6 ‘column

For Each c In Range(“E3:E5”)

s = c

myArray = Split(s, ” “) ‘The quick brown fox –> myarray(0)=The, myarray(1)=quick,etc

first = LBound(myArray)
last = UBound(myArray)

lengthofarray = last – first

‘MsgBox lengthofarray

For i = 0 To lengthofarray

If myArray(i) Like “[A-Za-z]#######” Then

‘initially x=3, y=6

Cells(x, y) = myArray(i)

y = y + 1

End If

Next i

x = x + 1
y = 6

lengthofarray = 0

Next c

End Sub