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

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

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

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

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