Excel VBA - 從電子郵件中復制逗號分隔的句子以分隔 Excel 單元格

Question

我試圖在 Excel VBA 腳本中包含一行，該行標識了在多封電子郵件正文中出現“關鍵字：”之后出現的句子中的所有文本，並將每個逗號分隔的單詞復制到單獨的 Excel 單元格中。 短語可以是任何東西，總是一個詞，但不能預定義。 例如，電子郵件包含如下一行：

Keyword: phrase1, phrase2, phrase3, phrase4

結果，在 Excel 中：

First email: A1 phrase1 B1 phrase2 etc.    
Second email: A2 phrase1 B2 phrase2 etc.

我試過使用類似以下的東西，但不知道從哪里開始：

CreateObject("VBScript.RegExp").Pattern = "((Keyword:)\s*(\w*),\s*(\w*),\s*(\w*),\s*(\w*),\s*(\w*))" 

這是我到目前為止所擁有的：

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

編輯：為了澄清這些短語不是預先定義的，它們可以是任何東西。

EDIT2：澄清電子郵件的正文包含“關鍵字：”，后跟逗號分隔的單個單詞，每個單詞要復制到自己的 Excel 單元格中。

Answer 1

在這里，我使用 instr 遍歷一系列短語以查找該階段在郵件項目主題中的位置。 如果位置大於 0，我用它來計算要寫入工作表的主題葯水。

---

Count_Emails 使用 ParamArray 在 VBA 2003 或更早版本中最多接受 29 個參數，在 VBA 2007 或更高版本中最多接受 60 個參數。

例如，如果您只想搜索一個詞組：

NumberOfEmails = Count_Emails("Phrase1")

另一方面，如果您需要搜索三個短語，只需將它們添加為附加參數

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

如果我正確地得到了你的目標（見評論），你可以修改你的代碼如下：

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 3

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