Excel VBA – 从电子邮件复制逗号分隔句子到单独的Excel单元格
我正在尝试在Excel VBA脚本中包含一行，在多个电子邮件正文中出现“Keyword：”后出现的句子中的所有文本，并将每个逗号分隔的单词复制到单独的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
编辑：澄清这些短语没有预先定义，他们可能是任何东西。
编辑2：澄清，电子邮件的正文包含“关键字：”，后面用逗号分隔的单词，要复制到他们自己的Excel单元格。
在这里，我使用instr遍历一组短语来查找邮件主题中相位的位置。 如果位置大于0，我用它来计算要写入工作表的主题药水。
Count_Emails使用ParamArray在VBA 2003或更早版本中接受多达29个参数，在VBA 2007或更高版本中最多接受60个参数。
例如，如果你只想search一个单词：
NumberOfEmails = Count_Emails（“Phrase1”）
另一方面，如果您有三个需要search的短语，只需将它们添加为其他参数即可
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
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
如果我正确地得到你的目标（见评论），你可以修改你的代码如下：
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