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("[email protected]") 
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("[email protected]") 
    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("[email protected]") 
    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