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接受多達29個參數在2003年VBA或更早和高達60個論據在2007年或以後VBA。

例如，如果你只是想尋找一個短語：

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