Excel VBA - 電子メールから別々のExcelセルにカンマ区切り文をコピーする

Question

"Keyword："の本文に現れる文の中のすべてのテキストを特定するExcel VBAスクリプトに行を挿入しようとしています。カンマ区切りの単語をそれぞれ別々のExcelセルにコピーします。フレーズは何でもかまいませんが、常に1つの単語ですが、あらかじめ定義することはできません。 Excelで

Keyword: phrase1, phrase2, phrase3, phrase4 

結果、：：私は、次のようなものを使用しようとしましたが、そこからどこへ行くかわからない

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 

EDIT：フレーズがあらかじめ定義されていないことを明確にするため、何でも構いません。

EDIT2：電子メールの本文には、「キーワード：」とそれに続くカンマ区切りの1つの単語が含まれており、各単語はそれぞれのExcelセルにコピーされます。

Answer 1

ここでは、instrを使ってフレーズの配列を繰り返して、メールアイテムの件名にあるフェーズの位置を見つけます。 0より大きい場合は、ワークシートに書き込む対象のポーションを計算するために使用します。

---

Count_Emails VBA 2003以前では29個の引数とVBA 2007以降で最大60個のまでの引数を受け入れるためにParamArrayはを使用しています。あなたは、単一の語句を検索したい場合など

：あなたが検索する必要がある、あなたの持っていた3つのフレーズ一方

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