通过解析将数据从 Outlook 导出到 Excel答案

【问题标题】：Exporting data from outlook to excel with parsing通过解析将数据从 Outlook 导出到 Excel
【发布时间】：2020-03-09 20:07:28
【问题描述】：

我在电子邮件中收到了如下所示的表格。

提交的详细信息如下：

Region Europe
Country Spain
Contactable by email no
Contactable by phone no
Title MR
First name John
Last name Doe
Email j.doe@doe.com
Contact number 1234567
Role Customer
Institution companyname ltd
Product TEST product
Message 
TEST Question

我需要将一些字段提取到 Excel 工作簿中。

我一直在手动输入这些电子邮件，所以我需要找到一个代码来将数据提取到下一个空行中。

我的 Excel 标题如下所示

Excel columns

我在这里检查了一些答案，并设法整理了一个代码，但它似乎没有按需要工作。

这是我目前所拥有的。

我将它输入到 Outlook VBA 模块中。

Sub Extract()

    Dim myOlApp As Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim topOlFolder As Outlook.MAPIFolder
    Dim myOlFolder As Outlook.Folder
    Dim myOlMailItem As Outlook.MailItem

    Set myNameSpace = Outlook.Application.GetNamespace("mapi")
    Set objItem = objApp.ActiveExplorer.Selection.Item(1)

    Dim xlObj As worksheet
    Set xlObj = ActiveSheet                          

    Dim anchor As Range
    Set anchor = xlObj.Range("b2")                   

        anchor.Offset(0, 0).Value = "Country"          
    anchor.Offset(0, 1).Value = "Role"         
    anchor.Offset(0, 2).Value = "Product"
    anchor.Offset(0, 3).Value = "Message"
    anchor.Offset(0, 4).Value = "Sender"


    Dim msgText As String
    Dim msgLine() As String
    Dim messageArray() As String

    i = 0                                            
    For Each myOlMailItem In myOlFolder.Items
        i = i + 1                                    

        msgText = myOlMailItem.Body                  

        messageArray = Split(msgText, vbCrLf)       

        For j = 0 To UBound(messageArray)

            msgLine = Split(messageArray(j) & ":", ":")  

            Select Case Left(msgLine(0), 6)              

                Case "Countr"
                    anchor.Offset(i, 0).Value = msgLine(1)             

                Case "Role"
                    anchor.Offset(i, 1).Value = messageArray(j + 1)   

                Case "Product"
                    anchor.Offset(i, 2).Value = messageArray(j + 1)    

                Case "Message"
                    anchor.Offset(i, 3).Value = msgLine(1)             

            End Select
            anchor.Offset(i, 4).Value = myOlMailItem.SenderName
            anchor.Offset(i, -1).Value = i                             

        Next
    Next
End Sub

非常感谢您的帮助和 cmets。

编辑：

我已经运行了诊断工具，这就是电子邮件正文的样子：

     |Message ‹2 crlf›|
      |TEST question - please confirm receipt if received. ‹2 crlf›|
      |AAA-BBB-001366 ‹2 crlf›|
      |JAN 2020 ‹2 crlf›|
      | ‹2 crlf›|
      |info.com <http://info.com/?mc_phishing_protection_id=xxxbpg|
      |db3lse2ip1c6bc0n0>‹2 s›‹2 crlf›|
      | ‹2 crlf›|
      | ‹3 crlf›|
      |This email (including any attachment) is intended only for the use by the recipients named above and|
      | contains proprietary information that may be confidential, copyrighted and/or privileged. Unauthori|
      |zed disclosure, use or copying is prohibited. If this email was sent to you in error or if you are n|
      |ot an intended recipient, please notify the sender immediately and delete this e-mail from your syst|
      |ems. Thank you‹crlf›|
Html: |<html xmlns:v="urn:schemas-microsoft-com:vml" xmlns:o="urn:schemas-microsoft-com:office:office" xmln|
      |s:w="urn:schemas-microsoft-com:office:word" xmlns:m="http://schemas.microsoft.com/office/2004/12/omm|
      |l" xmlns="http://www.w3.org/TR/REC-html40"><head>‹2 crlf›|
      |<meta name="Generator" content="Microsoft Word 15 (filtered medium)">‹crlf›|
      |<title>Simple Transactional Email</title>‹crlf›|
      |<style><!--‹crlf›|
      |/* Font Definitions */‹crlf›|
      |@font-face‹crlf›|
      |‹tb›{font-family:"Cambria Math";‹crlf›|
      |‹tb›panose-1:2 4 5 3 5 4 6 3 2 4;}‹crlf›|
      |@font-face‹crlf›|
      |‹tb›{font-family:Calibri;‹crlf›|
      |‹tb›panose-1:2 15 5 2 2 2 4 3 2 4;}‹crlf›|
      |/* Style Definitions */‹crlf›|
      |p.MsoNormal, li.MsoNormal, div.MsoNormal‹crlf›|
      |‹tb›{margin:0cm;‹crlf›|
      |‹tb›margin-bottom:.0001pt;‹crlf›|
      |‹tb›font-size:11.0pt;‹crlf›|
      |‹tb›font-family:"Calibri",sans-serif;}‹crlf›|
      |a:link, span.MsoHyperlink‹crlf›|
      |‹tb›{mso-style-priority:99;‹crlf›|
      |‹tb›color:blue;‹crlf›|
      |‹tb›text-decoration:underline;}‹crlf›|
      |a:visited, span.MsoHyperlinkFollowed‹crlf›|
      |‹tb›{mso-style-priority:99;‹crlf›|
      |‹tb›color:purple;‹crlf›|
      |‹tb›text-decoration:underline;}‹crlf›|
      |p.msonormal0, li.msonormal0, div.msonormal0‹crlf›|
      |‹tb›{mso-style-name:msonormal;‹crlf›|
      |‹tb›mso-margin-top-alt:auto;‹crlf›|
      |‹tb›margin-right:0cm;‹crlf›|
      |‹tb›mso-margin-bottom-alt:auto;‹crlf›|
      |‹tb›margin-left:0cm;‹crlf›|
      |‹tb›font-size:11.0pt;‹crlf›|
      |‹tb›font-family:"Calibri",sans-serif;}‹crlf›|
      |span.preheader‹crlf›|
      |‹tb›{mso-style-name:preheader;}‹crlf›|
      |span.EmailStyle19‹crlf›|
      |‹tb›{mso-style-type:personal;‹crlf›|
      |‹tb›font-family:"Calibri",sans-serif;‹crlf›|
      |‹tb›color:windowtext;}‹crlf›|
      |span.EmailStyle22‹crlf›|
      |‹tb›{mso-style-type:personal-reply;‹crlf›|
      |‹tb›font-family:"Calibri",sans-serif;‹crlf›|
      |‹tb›color:windowtext;}‹crlf›|
      |.MsoChpDefault‹crlf›|
      |‹tb›{mso-style-type:export-only;‹crlf›|
      |‹tb›font-size:10.0pt;}‹crlf›|
      |@page WordSection1‹crlf›|
      |‹tb›{size:612.0pt 792.0pt;‹crlf›|
      |‹tb›margin:72.0pt 72.0pt 72.0pt 72.0pt;}‹crlf›|
      |div.WordSection1‹crlf›|
      |‹tb›{page:WordSection1;}‹crlf›|
      |--></style><!--[if gte mso 9]><xml>‹crlf›|
      |<o:shapedefaults v:ext="edit" spidmax="1026" />‹crlf›|
      |</xml><![endif]--><!--[if gte mso 9]><xml>‹crlf›|
      |<o:shapelayout v:ext="edit">‹crlf›|
      |<o:idmap v:ext="edit" data="1" />‹crlf›|
      |</o:shapelayout></xml><![endif]-->‹crlf›|
      |</head>‹crlf›|
      |<body bgcolor="#F6F6F6" lang="EN-US" link="blue" vlink="purple"><pre><div style="background-color:#F|
      |FEB9C; width:100%; max-width:1040px; border-style: solid; border-color:#9C6500; border-width:1pt; pa|
      |dding:2pt; font-size:10pt; line-height:12pt; font-family:'Calibri'; color:Black; text-align: left;">|
      |<span style="color:#9C6500; font-weight:bold;">CAUTION:</span>This email originated from outside of |
      |the Vifor Pharma Group organisation. Do not click on links or open attachments unless you recognise |
      |the sender and know the content is safe.</div>‹crlf›|
      |</pre>‹crlf›|
      |<div class="WordSection1">‹crlf›|
      |<p class="MsoNormal"><o:p>&nbsp;</o:p></p>‹crlf›|
      |<p class="MsoNormal"><o:p>&nbsp;</o:p></p>‹crlf›|
      |<p class="MsoNormal"><o:p>&nbsp;</o:p></p>‹crlf›|
      |<div>‹crlf›|
      |<div style="border:none;border-top:solid #E1E1E1 1.0pt;padding:3.0pt 0cm 0cm 0cm">‹crlf›|
      |<p class="MsoNormal"><b>From:</b> Info GM  &lt;<a href="mailto:noreply@info|
      |.com">noreply@info.com</a>&gt;‹crlf›|
      |<br>‹crlf›|
      |<b>Sent:</b> 19 February 2020 16:20<br>‹crlf›|
      |<b>To:</b> Info1 &lt;<a href="mailto:infor1@info.com">pharma|
      |info2@info.com</a>&gt;<br>‹crlf›|
      |<b>Cc:</b> GM &lt;<a href="mailto:info@info.com">GlobalMedInfo@info|
      |.com</a>&gt;<br>‹crlf›|
      |<b>Subject:</b> New query received<o:p></o:p></p>‹crlf›|
      |</div>‹crlf›|
      |</div>‹crlf›|
      |<p class="MsoNormal"><o:p>&nbsp;</o:p></p>‹crlf›|
      |<table class="MsoNormalTable" border="0" cellspacing="0" cellpadding="0" width="100%" style="width:1|
      |00.0%;background:#F6F6F6">‹crlf›|
      |<tbody>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 0cm 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">&nbsp;<|
      |o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td width="580" valign="top" style="width:435.0pt;padding:7.5pt 7.5pt 7.5pt 7.5pt">‹crlf›|
      |<div>‹crlf›|
      |<p class="MsoNormal"><span class="preheader"><span style="font-size:10.5pt;font-family:&quot;Arial&q|
      |uot;,sans-serif">New query received</span></span><span style="font-size:10.5pt;font-family:&quot;Ari|
      |al&quot;,sans-serif">‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |<table class="MsoNormalTable" border="0" cellspacing="3" cellpadding="0" width="100%" style="width:1|
      |00.0%;background:white;border-radius: 3px">‹crlf›|
      |<tbody>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:15.0pt 15.0pt 15.0pt 15.0pt;box-sizing: border-box">‹crlf›|
      |<table class="MsoNormalTable" border="0" cellspacing="0" cellpadding="0" width="100%" style="width:1|
      |00.0%;box-sizing: border-box">‹crlf›|
      |<tbody>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 0cm 0cm">‹crlf›|
      |<p style="mso-margin-top-alt:0cm;margin-right:0cm;margin-bottom:11.25pt;margin-left:0cm">‹crlf›|
      |<span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">New product complaint query |
      |received from info.com<o:p></o:p></span></p>‹crlf›|
      |<p style="mso-margin-top-alt:0cm;margin-right:0cm;margin-bottom:11.25pt;margin-left:0cm">‹crlf›|
      |<span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">The submitted details are be|
      |low:<o:p></o:p></span></p>‹crlf›|
      |<table class="MsoNormalTable" border="0" cellspacing="0" cellpadding="0" width="100%" style="width:1|
      |00.0%;background:white;box-sizing: border-box">‹crlf›|
      |<tbody>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Region|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Europe|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Country|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Switzer|
      |land‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Title|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Ms|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">First n|
      |ame‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Joe|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Last na|
      |me‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Doe|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Email|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif"><a href|
      |="mailto:Joe.Doe.ext@info.com">Joe.Doe.ext@info.com</a>‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Contact|
      | number‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm"></td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Role|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Other|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Institu|
      |tion‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm"></td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Product|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |<td valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">TEST pr|
      |oduct‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td colspan="2" valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">Message|
      |‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td colspan="2" valign="top" style="padding:0cm 0cm 11.25pt 0cm">‹crlf›|
      |<p class="MsoNormal"><i><span style="font-size:10.5pt;font-family:&quot;Arial&quot;,sans-serif">TEST|
      | question - please confirm receipt if received.‹crlf›|
      |<o:p></o:p></span></i></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td colspan="2" valign="top" style="padding:0cm 0cm 0cm 0cm">‹crlf›|
      |<p class="MsoNormal" align="right" style="text-align:right"><span style="font-size:10.5pt;font-famil|
      |y:&quot;Arial&quot;,sans-serif">ALL-ALL-001366‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |<tr>‹crlf›|
      |<td colspan="2" valign="top" style="padding:0cm 0cm 0cm 0cm">‹crlf›|
      |<p class="MsoNormal" align="right" style="text-align:right"><span style="font-size:10.5pt;font-famil|
      |y:&quot;Arial&quot;,sans-serif">JAN 2020‹crlf›|
      |<o:p></o:p></span></p>‹crlf›|
      |</td>‹crlf›|
      |</tr>‹crlf›|
      |</tbody>‹crlf›|

我已经运行了这个工具，这里是文本：

【问题讨论】：

什么不起作用？你能说得更具体点吗？
msgLine = Split(messageArray(j) & ":", ":")的目的是什么？
当我运行这个宏时，我收到一条消息编译错误：未定义用户定义的类型。 msgLine = Split(messageArray(j) & ":", ":") 应该分行
messageArray = Split(msgText, vbCrLf) 将电子邮件的正文分成几行。如果一行包含冒号（例如，“Region: Europe”），那么msgLine = Split(messageArray(j), ":") 会将这一行拆分为关键字和值。你认为 ` & ":"` 对示例行有什么作用？
看看这个问题和我的回答：stackoverflow.com/q/54178058/973283。 OP 想要一个 Excel 宏，它从选定的电子邮件中提取选定的值并将它们添加到工作表的底部。提取过程与您的非常不同，但整体结构将相似。

标签： excel vba outlook

【解决方案1】：

我已将Option Explicit 添加到您的代码顶部。这对于查找编译时错误非常有帮助。

Dim myOlApp As Outlook.Application
Set objItem = objApp.ActiveExplorer.Selection.Item(1)

你声明了myOlApp，但你使用objApp而不初始化它。

Dim myOlMailItem As Outlook.MailItem
Set objItem = myOlApp.ActiveExplorer.Selection.Item(1)

您声明了myOlMailItem，但您使用了objItem。

i = 0
For j = 0 To UBound(messageArray)

您没有声明i 或j。如果省略Option Explicit，则不必声明每个变量，因为它们将为您声明为 Variant 类型。然而，这意味着每一个小的拼写错误都会变成一个新的变量。例如：

Count = Conut +1

Conut 将被声明为一个新变量并初始化为零。

我没有收到“未定义用户定义的类型”。想到这一点，我意识到我对这段代码的放置位置做出了错误的假设。

例如，您编写 Dim myNameSpace As Outlook.NameSpace 和 Dim anchor As Range。

您可以在 Outlook 中编写 VBA 来访问 Excel 工作表，也可以在 Excel 中编写 VBA 来访问 Outlook 文件夹。如果您在 Outlook 中，则必须告诉 Outlook VBA 编译器您要访问 Excel。反之亦然。您添加前缀NameSpace，但您不添加前缀Range。我假设这段代码在 Excel 工作簿中。但经过反思，我现在相信这段代码在 Outlook 中。在重读您的问题时，我看到您说它是 Outlook VBA；我在第一次阅读时错过了这一点。

这段代码放在哪里并不重要；它不能工作。如果您在 Outlook 中，则必须先打开 Excel 工作簿才能引用活动工作表。如果您在 Excel 中，用户选择了哪个电子邮件？

让我们从代码中退后一步，考虑一下您的设计选项。

使用ActiveExplorer 是我最喜欢的测试新电子邮件处理宏的方法。我可以为我的第一次测试选择一个简单的电子邮件。我可以根据需要更正宏并针对同一封电子邮件重新运行它。一旦宏适用于简单的电子邮件，我就可以在更复杂的电子邮件上尝试它。但是，一旦我的新宏正常工作，我想自动进行选择。我不想去想：“现在是 12:00，今天早上有这些邮件到了吗？如果是这样，我需要进入 Outlook，找到任何已到达并处理它们。”我想：“现在是 12:00，有没有新邮件复制到我的 Excel 工作簿中。”

选择电子邮件进行处理有四种不同的方法。你不能混搭。这些方法是：

用户选择是您正在尝试的方法。
您可以向下读取文件夹（从最旧到最新）或向上读取文件夹（从最新到最旧），或者您可以按任何常规属性对文件夹进行排序。
您可以创建一个规则，告诉 Outlook 监控收件箱中的特定电子邮件并在收到电子邮件时执行某些操作。
您可以使用事件告诉 Outlook 在新电子邮件放入特定文件夹时调用宏。

使用方法 1，由用户识别要处理的电子邮件。对于其他方法，必须有一个宏可以执行的测试。这些电子邮件都是来自同一个发件人吗？这些电子邮件是否有特定的主题或主题中的特定短语？如果没有通过简单的检查，您可以在正文中查找“地区”、“国家/地区”和“联系方式”。

方法 3 和 4 的一个问题是，当其中一封电子邮件到达时会调用宏。宏必须快速打开工作簿、更新它并关闭它。如果在用户处理工作簿时收到一封电子邮件，会发生什么？如果我是 VBA 新手，我不想解决这个问题。

我将使用方法 2。我将有一个 Excel 工作簿，其中包含一个宏，该宏可以访问 Outlook 的收件箱并查看任何目标电子邮件的最新电子邮件。这不是我所说的我想要的，但它已经足够接近了。每次打开工作簿时，如果我愿意，我可以运行宏来处理任何新电子邮件。如果宏定期运行，这应该只需要几秒钟。

使用规则将这些电子邮件移动到专用文件夹可能是值得的。这意味着宏不必在收件箱中搜索这些电子邮件。这看起来好像我在混合方法 2 和 3，但不在同一个宏中。每当您打开 Outlook 新电子邮件从服务器到达时，该规则会将任何目标电子邮件移至其文件夹。当您打开工作簿时，您可以决定检查新的目标电子邮件或查看已记录在工作簿中的那些电子邮件。

我认为这足以让您暂时考虑一下。查看我讨论过的方法，并就您想要什么做出一些决定。

第 2 部分

我今晚没有预期的空闲时间，所以我怀疑我今天能不能完成。我还有一个问题，我应该就您的要求提出更多问题。

为了给你明天看的东西，我制作了一个演示宏，其中包含很多你需要知道的内容，我认为这些对你理解最终的宏很有帮助。

我创建了一个工作簿和工作表，其标题与您的问题中显示的相匹配。我已将工作簿命名为“Email Data.xlsx”并将其放在我的桌面上。我已将工作表命名为“电子邮件数据”。我假设你有不同的名字和不同的位置。宏告诉您要更改的内容。

想要访问 Excel 工作簿的 Outlook 宏必须有权访问 Excel 库。您可能知道如何添加引用，但以防万一：

打开 Outlook VBA 编辑器。
单击标准工具栏中的 [工具]，然后单击 [参考...]。
显示可用参考列表。顶部的一些可用参考（例如 Visual Basic for Application）已打勾。大多数参考文献没有打勾。
如果勾选了“Microsoft Excel nn.n 对象库”，请单击[取消]，因为没有任何操作。注意：“nn.n”的值取决于您使用的 Outlook 和 Excel 版本。此代码应适用于任何版本的 Excel，因此您是否使用旧版本也没关系。
如果未勾选“Microsoft Excel nn.n 对象库”，请向下滚动列表直到找到此引用，然后单击左侧的框以勾选它。
点击[确定]。
重复第 2 步并检查“Microsoft Excel nn.n 对象库”现在是否出现在列表顶部并被勾选。

将此宏复制到 Outlook 模块：

Option Explicit
Sub DemoOpenWorkbook()

  ' Needs reference to Microsoft Excel n.nn Object Library
  ' where n.nn depends on the version of Office being used

  Dim Path As String
  Dim WbkEmailData As Excel.Workbook
  Dim WshtEmailData As Excel.Worksheet
  Dim XlApp As New Excel.Application

  ' Replace with path to the folder which holds your workbook
  Path = CreateObject("WScript.Shell").specialfolders("Desktop")

  With XlApp
    .Visible = True   ' Slows your application but makes debugging easier
    ' Replace "Email Data.xlsx" with the name of your workbook
    Set WbkEmailData = .Workbooks.Open(Path & "\Email Data.xlsx")
  End With

  With WbkEmailData
    ' Replace "Email Data" with the name of your worksheet
    Set WshtEmailData = .Worksheets("Email Data")
  End With

  With WshtEmailData
    Debug.Print .Cells(1, 1).Value
    Debug.Print .Cells(1, 2).Value
    Debug.Print .Cells(1, 3).Value
  End With

  WbkEmailData.Close
  Set WshtEmailData = Nothing
  Set WbkEmailData = Nothing
  XlApp.Quit
  Set XlApp = Nothing

End Sub

进行我上面讨论过的更改。运行宏。工作簿打开，工作表的前三个标题输出到即时窗口，工作簿关闭。立即窗口现在将包含：

DATE OF RECEIPT
DELIVERY DATE
MONTH

编写我的代码。如果您不理解我的任何陈述，请查阅它们。通常，在您最喜欢的搜索引擎中键入“Outlook VBA 语句名称-您不理解”之类的内容会找到解释。如有必要，请提出问题，但我希望您能理解为什么此代码可以在没有我更多帮助的情况下工作。

注意：您不需要记住此代码。有一些 VBA 语句和 VBA 代码块，我经常键入足以记住它们。但我并不羞于查找我不经常使用的东西，或者回顾一个与我今天想做的事情相似的工作宏。

第 3 部分

接下来的两个宏演示了我最喜欢的测试新电子邮件处理宏的技术。在TestNewEmailProcessingMacro 的底部附近，您会发现声明Call EmailProcessingMacro(ItemCrnt)。当我创建一个新的电子邮件处理宏时，我修改了这个语句来调用我的新宏。然后，在运行TestNewEmailProcessingMacro() 之前，我选择了我的宏进程类型的简单电子邮件。我仔细检查了我的宏是否正确处理了简单的电子邮件。如果没有，我可以根据需要更正宏并重新运行测试。一旦我的宏正确处理了一封简单的电子邮件，我就可以尝试更复杂的电子邮件。我继续，直到我的宏执行到我完全满意为止。然后，我将从循环、规则或事件中调用我的新宏，如答案的第一部分所述。

Sub TestNewEmailProcessingMacro()

  Dim Exp As Explorer
  Dim ItemCrnt As MailItem

  Set Exp = Outlook.Application.ActiveExplorer

  If Exp.Selection.Count = 0 Then
    Call MsgBox("Please select one or more emails then try again", vbOKOnly)
    Exit Sub
  Else
    For Each ItemCrnt In Exp.Selection
      If ItemCrnt.Class = olMail Then
        Call EmailProcessingMacro(ItemCrnt)
      End If
    Next
  End If

End Sub
Public Sub EmailProcessingMacro(ByRef ItemCrnt As MailItem)

  With ItemCrnt
    Debug.Print .ReceivedTime & " " & .Subject
  End With

End Sub

以上代码展示了如何正确使用资源管理器。在您的代码中，您有Set objItem = objApp.ActiveExplorer.Selection.Item(1)。即使未选择任何电子邮件，这也会尝试访问第一封选定的电子邮件，并忽略已选择的任何其他电子邮件。

接下来我将向您展示如何结合上述宏中显示的技术。

第 4 部分

下面是两个宏，它们一起做我认为你想要的。

您需要进行与DemoOpenWorkbook() 相同的更改。也就是说，您必须更改路径、工作簿名称和工作表名称。您无需再添加对 Excel 库的引用，一次就足够了。

选择其中一封或多封电子邮件，然后运行宏CtrlCopyEmailDataToExcel()。这是打开工作簿然后保存更改的宏。此宏为每个选定的电子邮件调用 CopyEmailDataToExcel()。这是解码电子邮件正文并从中提取四个值并将它们复制到工作表的宏。它还从电子邮件中提取所需的属性并将它们复制到工作簿中。我已经记录了我对宏中的电子邮件和工作表的所有假设。复制您的工作簿，以防我的假设不正确，并且宏会损坏工作簿。不过，我希望宏能满足您的要求。

我希望我已经解释了我的代码背后的原理，以便您了解正在发生的事情，并可以创建自己的宏来执行类似的数据从电子邮件到 Excel 的复制。

Sub CtrlCopyEmailDataToExcel()

  ' Extracts data from selected emails and copies it to Excel

  ' Needs reference to Microsoft Excel n.nn Object Library
  ' where n.nn depends on the version of Office being used

  Dim Exp As Explorer
  Dim ItemCrnt As MailItem
  Dim Path As String
  Dim RowCrnt As Long
  Dim WbkEmailData As Excel.Workbook
  Dim WshtEmailData As Excel.Worksheet
  Dim XlApp As New Excel.Application

  Set Exp = Outlook.Application.ActiveExplorer

  If Exp.Selection.Count = 0 Then
    Call MsgBox("Please select one or more emails then try again", vbOKOnly)
    Exit Sub
  Else

    ' Replace with path to the folder which holds your
    Path = CreateObject("WScript.Shell").specialfolders("Desktop")

    With XlApp
      .Visible = True   ' Slows your application but makes debugging easier
      ' Replace "Email Data.xlsx" with the name of your workbook
      Set WbkEmailData = .Workbooks.Open(Path & "\Email Data.xlsx")
    End With

    With WbkEmailData
      ' Replace "Email Data" with the name of your worksheet
      Set WshtEmailData = .Worksheets("Email Data")
    End With

    With WshtEmailData
      ' If the cursor is placed in the bottom cell of column A and Up Arrow
      ' clicked, the cursor will be move up to the last row with data in
      ' column A.  This is the VBA equivalent.  Adding 1 means RowCrnt will
      ' become the number of the first unused row.  This relies on every
      ' used row having a value column A. Replace "A" if another column is
      ' a better choice.  If no column is guaranteed to not contain blank
      ' cell, I can provide a routine that finds the last used row in a
      ' different way.
      RowCrnt = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    End With

    For Each ItemCrnt In Exp.Selection
      Call CopyEmailDataToExcel(ItemCrnt, WshtEmailData, RowCrnt)
    Next
  End If

  WbkEmailData.Close SaveChanges:=True
  Set WshtEmailData = Nothing
  Set WbkEmailData = Nothing
  XlApp.Quit
  Set XlApp = Nothing

End Sub
Sub CopyEmailDataToExcel(ByRef ItemCrnt As MailItem, _
                         ByRef WshtEmailData As Worksheet, _
                         ByRef RowCrnt As Long)

  ' The Body of ItemCrnt is the HtmlBody with all the Html tags stripped out.

  ' Most the HtmlBody was a table with two cells per row.  The left-hand cell
  ' would be a keyword such as "Country", "Role" or "Product" while the
  ' right-hand cell would be the value associated with the keyword. The nature
  ' of the HtmBody and the nature of the conversion to text means a table row
  ' would become, for example: Country CR LF CR LF France CR LF CR LF

  ' The bottom of the table had only one cell per row. This is achieved with a
  ' "ColSpan = 2" attribute in the first and only <td> of the row.  The change
  ' of style starts with a cell containing "Message". These final rows are:
  ' Message CR LF CR LF Line1 CR LF CR LF Line2 CR LF CR LF ...
  ' The last two lines of this block are not required.

  ' The start of Body did not come from the same Html table and the format is
  ' slightly different.  However, the start of Body contains nothing of
  ' interest.

  ' Two properties of ItemCrnt are to be copied to the worksheet: SentOn (Date
  ' email sent) and SenderName.

  ' The month of property Sent On is required for another column.

  ' This routine copies the seven values from ItemCrnt to RowCrnt of the
  ' worksheet and then steps RowCrnt ready for the next row.

  Const ColReceived As Long = 1
  Const ColSentOn As Long = 2    ' Delivery Date
  Const ColMonth As Long = 3
  Const ColCountry As Long = 4
  Const ColEnqType As Long = 6   ' Role
  Const ColProduct As Long = 7
  Const ColMessage As Long = 8   ' Question

  Dim BodyLines() As String
  Dim InxL As Long
  Dim Key As String
  Dim LenKey As Long
  Dim Message As String
  Dim MessageFound As Boolean
  Dim Ub As Long

  ' At the start of ItemCrnt.Body, the lines are separated by single CRLFs.
  ' However, the start of ItemCrnt.Body contains nothing of interest so it
  ' does not matter that it is not split correctly.
  BodyLines = Split(ItemCrnt.Body, vbCrLf & vbCrLf)

  ' Ignore any trailing blank lines
  For Ub = UBound(BodyLines) To LBound(BodyLines) Step -1
    If BodyLines(Ub) <> "" Then
      Exit For
    End If
  Next

  With WshtEmailData

    MessageFound = False
    InxL = LBound(BodyLines)
    Do While InxL <= Ub

      If InStr(1, BodyLines(InxL), "Country") <> 0 Then
        ' The country is the next row
        InxL = InxL + 1
        .Cells(RowCrnt, ColCountry).Value = BodyLines(InxL)
      ElseIf InStr(1, BodyLines(InxL), "Role") <> 0 Then
        ' The role is the next row
        InxL = InxL + 1
        .Cells(RowCrnt, ColEnqType).Value = BodyLines(InxL)
      ElseIf InStr(1, BodyLines(InxL), "Product") <> 0 Then
        ' The product is the next row
        InxL = InxL + 1
        .Cells(RowCrnt, ColProduct).Value = BodyLines(InxL)
      ElseIf InStr(1, BodyLines(InxL), "Message") <> 0 Then
         ' The message starts in the next row
       InxL = InxL + 1
        MessageFound = True
        Exit Do
      End If

      InxL = InxL + 1
    Loop

    If MessageFound Then

      'Build message as Line1 vbLF Line2 vbLF Line3 and so on
      Message = BodyLines(InxL)
      For InxL = InxL + 1 To Ub
        If BodyLines(InxL) = "AAA-BBB-001366" Then
          Exit For
        End If
        Message = Message & vbLf & BodyLines(InxL)
      Next

      With .Cells(RowCrnt, ColMessage)
        .Value = Message
        .WrapText = True
      End With
    End If

    With .Cells(RowCrnt, ColReceived)
      .Value = ItemCrnt.ReceivedTime
      .NumberFormat = "dmmmyy"
    End With

    With .Cells(RowCrnt, ColSentOn)
      .Value = ItemCrnt.SentOn
      .NumberFormat = "dmmmyy"
    End With

    With .Cells(RowCrnt, ColMonth)
      .Value = ItemCrnt.ReceivedTime
      .NumberFormat = "mmm"
    End With

  End With

  RowCrnt = RowCrnt + 1

End Sub

【讨论】：

非常感谢您的 cmets。我真的很感谢你的帮助。我将查看我的代码，再次阅读您的 cmets，然后返回希望结构更好的代码。
在考虑了我的情况后，我得出结论，我需要一个 Outlook 宏，因为收到的一些电子邮件没有输入到 Excel 工作表中，因为它们是垃圾邮件或无关紧要。因此，我更愿意选择一封电子邮件，阅读它，如果需要单击宏，然后将其移动到不同的文件夹。
@CatBehemoth 抱歉，我正忙于处理别人的问题。我会尽快回复您。
@CatBehemoth 在您的示例中，您有诸如“欧洲地区”之类的行。这是一种可能的格式，但更常见的格式是“地区：欧洲”。您的代码包含一个似乎试图在冒号上拆分行的语句。请确认您的行的格式。
@CatBehemoth 回顾您问题中的正文，我发现终止值不是“AAA-BBB-001366”而是“AAA-BBB-001366”。也就是说，最后有一个空格。您可以将空格添加到文字中，也可以尝试类似：If Left$(BodyLines(InxL), 7) = "AAA-BBB" Then。前者更容易，但如果空间来来去去，代码可能无法正常工作。

【解决方案2】：

对于这种格式的消息，忽略来自 OP 的更多细节。

欧洲地区
国家西班牙
可通过电子邮件联系没有
电话联系不上
标题 MR
名字约翰
姓氏
电子邮件 j.doe@doe.com
联系电话1234567
角色客户
机构公司名称有限公司
产品测试产品
留言
测试题

结构化文本，但在标签和响应之间没有“:”或其他唯一字符的行。这里的空格是不够的，作为一个独特的字符，因为一些标签包含一个空格。

标签和响应之间存在唯一字符 Search structured text in Outlook body 的结构化文本代码将不适用。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration

Sub Extract_noDelimiterToDetermineLabel()

    ' code is in Excel

    Dim myOlApp As Outlook.Application
    Dim myNameSpace As Outlook.Namespace

    Dim objItem As Object
    Dim myOlMailItem As Outlook.MailItem

    Dim msgText As String
    'Dim msgLine() As String
    Dim messageArray() As String

    Dim xlObj As Worksheet
    Dim anchor As Range

    Dim i As Long
    Dim j As Long

    ' Unusual technique
    '  Outlook is assumed to be open since a mailitem is selected
    Set myNameSpace = Outlook.Application.GetNamespace("mapi")
    Set myOlApp = myNameSpace.Parent
    Set objItem = myOlApp.ActiveExplorer.Selection.Item(1)

    Set xlObj = ActiveSheet
    Set anchor = xlObj.Range("b2")

    anchor.Offset(0, 0).Value = "Country"
    anchor.Offset(0, 1).Value = "Role"
    anchor.Offset(0, 2).Value = "Product"
    anchor.Offset(0, 3).Value = "Message"
    anchor.Offset(0, 4).Value = "Sender"

    i = 0

    If objItem.Class = olMail Then

        Set myOlMailItem = objItem

        i = i + 1

        msgText = myOlMailItem.Body

        messageArray = Split(msgText, vbCrLf)

        ' Cannot split messageArray elements further since
        '  no character to separate label from response.
        ' Cannot use standard "ParseTextLinePair" code.
        '  https://stackoverflow.com/questions/20001670/search-structured-text-in-outlook-body

        For j = 0 To UBound(messageArray)

            If Left(messageArray(j), 4) <> "" Then

                ' The suggested customized technique
                '  depends on there being unique characters to identify the line
                'Debug.Print Left(messageArray(j), 4)

                Select Case Left(messageArray(j), 4)

                    Case "Coun"
                        anchor.Offset(i, 0).Value = Right(messageArray(j), Len(messageArray(j)) - Len("Country "))

                    Case "Role"
                        anchor.Offset(i, 1).Value = Right(messageArray(j), Len(messageArray(j)) - Len("Role "))

                    Case "Prod"
                        anchor.Offset(i, 2).Value = Right(messageArray(j), Len(messageArray(j)) - Len("Product "))

                    Case "Mess"
                        anchor.Offset(i, 3).Value = messageArray(j + 2)

                        anchor.Offset(i, 4).Value = myOlMailItem.SenderName
                        anchor.Offset(i, -1).Value = i

                End Select

            End If

        Next

    End If

End Sub

【讨论】：

我尝试运行上述宏，但在Set anchor = xlObj.Range("b2") 行中出现错误“运行时错误 91 对象变量或未设置块变量”
不，在 Outlook 中。
根据问题中的代码，代码适用于 Excel。在运行它之前，请转到 Outlook 并选择一个测试项。
我会尝试回来的。谢谢
我已经尝试了代码，它复制了电子邮件的一些位，但复制到了随机单元格。我会尝试修改代码，看看会发生什么。