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

Excel VBA - 将逗号分隔的句子从电子邮件复制到单独的Excel单元格

3 个答案: