Excel VBA - Copy comma seperated sentence from emails to seperate Excel cells - vba

Question

I am trying to include a line in an Excel VBA script which identified all the text in a sentence that appears after the occurance of "Keyword:" in the body of multiple emails and copies each comma separated word into separate Excel cells. The phrases could be anything, always a single word but can't be predefined. For example, the email contained a line like:
Keyword: phrase1, phrase2, phrase3, phrase4
The result, in Excel:
First email: A1 phrase1 B1 phrase2 etc.
Second email: A2 phrase1 B2 phrase2 etc.
I've tried to use something like the following but don't know where to go from there:
CreateObject("VBScript.RegExp").Pattern = "((Keyword:)\s*(\w*),\s*(\w*),\s*(\w*),\s*(\w*),\s*(\w*))"
Here's what I have so far:
Option Compare Text
Sub Count_Emails()
Dim oNS As Outlook.Namespace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oFoldToSearch As Object
Dim intCounter As Integer
Dim oWS As Worksheet
Dim dStartDate, dEnddate As Date
Set oWS = Sheets("Sheet1")
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates#microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items
intCounter = 1
dStartDate = oWS.Range("A1").Value
dEnddate = oWS.Range("B1").Value
Do
With oWS
If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
oItems(intCounter).Subject Like "*Keyword:*" Then
'Something needs to happen here? A VBScript.RegExp.Pattern maybe?
End If
End With
intCounter = intCounter + 1
Loop Until intCounter >= oItems.Count + 1
Set oNS = Nothing
Set oTaskFolder = Nothing
Set oItems = Nothing
End Sub
EDIT: To clarify that the phrases are not pre-defined, they could be anything.
EDIT2: To clarify that the body of the emails contains "Keyword:" followed by comma separated single words that are to be copied each into their own Excel cell.

Answer 1

Here I iterate over an array of phrases using instr to find the position of the phase in the mail item's subject. If the position in greater then 0 I use it to calculate the potion of the subject to write to the worksheet.
Count_Emails uses a ParamArray to accept up to 29 arguments in VBA 2003 or earlier and up to 60 arguments in VBA 2007 or later.
For Example if you only wanted to search for a single phrase:
NumberOfEmails = Count_Emails( "Phrase1" )
On the other hand if your had three phrases you need to search for, just add them as additional arguments
NumberOfEmails = Count_Emails( "Phrase1", "Phrase2", "Phrase3" )
Option Explicit
Option Compare Text
Function Count_Emails(ParamArray Phrases())
Dim Count as Long
Dim oNS As Outlook.Namespace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim phrase As Variant
Dim item As Object, oFoldToSearch As Object
Dim StartDate, EndDate As Date, MailDate As Date
Dim PhraseSize As Long, pos As Long
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates#microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items
With Sheets("Sheet1")
StartDate = .Range("A1").Value
EndDate = .Range("B1").Value
For Each item In oItems
MailDate = DateValue(item.ReceivedTime)
If MailDate >= StartDate And MailDate <= EndDate Then
For Each phrase In Phrases
pos = InStr(item.Subject, phrase)
If pos > 0 Then
With .Range("C" & Rows.Count).End(xlUp).Offset(1)
PhraseSize = Len(phrase)
.Value = Right(item.Subject, Len(item.Subject) - pos - PhraseSize + 1)
End With
Count = Count + 1
Exit For
End If
Next
End If
Next
End With
Set oNS = Nothing
Set oTaskFolder = Nothing
Set oItems = Nothing
Count_Emails = Count
End Function

Answer 2

Sub ExtractKeyWords(text As String)
Dim loc As Long
Dim s As String
Dim KeyWords
Dim Target As Range
loc = InStr(text, "Keyword:")
If loc > 0 Then
s = Trim(Right(text, Len(text) - loc - Len("Keyword:") + 1))
KeyWords = Split(s, ",")
With Worksheets("Sheet1")
If .Cells(1, .Columns.Count).End(xlToLeft) = "" Then
Set Target = .Cells(1, .Columns.Count).End(xlToLeft)
Else
Set Target = .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1)
End If
Target.Resize(UBound(KeyWords) + 1).Value = Application.Transpose(KeyWords)
End With
End If
End Sub

Answer 3

if I correctly get your aim (see comments) you could modify your code as follows:
Option Explicit
Option Compare Text
Sub Count_Emails()
Dim oNS As Outlook.NameSpace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim keyword As Variant
Dim item As Object, oFoldToSearch As Object
Dim StartDate, EndDate As Date, MailDate As Date
Dim pos As Long
Dim xlApp As Excel.Application '<--| early binding ==> add your project the reference to Microsoft Excel XX.Y Object library
Dim phrasesArr As Variant
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates#microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items
Set xlApp = GetExcel(True) '<--| get running instance of excel application
If xlApp Is Nothing Then
MsgBox "No Excel running instance", vbCritical + vbInformation
Exit Sub
End If
With xlApp.Sheets("Sheet1") '<--| this assumes that the running instance of excel has an open workbook with a sheet named "Sheet1"
StartDate = .Range("A1").Value
EndDate = .Range("B1").Value
For Each item In oItems
MailDate = DateValue(item.ReceivedTime)
If MailDate >= StartDate And MailDate <= EndDate Then
pos = InStr(item.Subject, "Keyword:") '<--| search for "Keyword:" in current mail subject
If pos > 0 Then '<--| if found...
phrasesArr = Split(Right(item.Subject, Leng(item.Subject) - pos - Len("keyword:")), ",") '<-- fill an array with "phrases" separated by commas after "keyword:"
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Resize(, UBound(phrasesArr) + 1).Value = phrasesArr '<--| write "phrases" in column "C" first non empty cell and its adjacent cells
End If
End If
Next
End With
Set xlApp = Nothing
Set oItems = Nothing
Set oFoldToSearch = Nothing
Set oTaskFolder = Nothing
Set oNS = Nothing
End Sub
Function GetExcel(Optional mustBeCurrent As Variant) As Excel.Application
Dim excelApp As Excel.Application
If IsMissing(mustBeCurrent) Then mustBeCurrent = False '<--| default is get an Excel object "at any cost", if it's not running then create it
On Error Resume Next
Set GetExcel = GetObject(, "Excel.Application") '<--| try getting a running Excel application
On Error GoTo 0
If GetExcel Is Nothing Then If Not mustBeCurrent Then Set GetExcel = CreateObject("Excel.Application") '<--| if no running instance of Excel has been found then open a new one
End Function