如何从电子邮件正文中复制特定文本？
How to copy specific text from the body of the email?
Option Explicit
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("impMail")
Set olItms = olFldr.Items
olItms.Sort "Subject"
For Each olMail In olItms
If InStr(olMail.Subject, "SubjectoftheEmail") > 0 Then
ThisWorkbook.Sheets("Fixings").Cells(2, 2).Value = olMail.Body
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
此代码可帮助我下载电子邮件的整个正文，但我需要单元格中的特定粗体文本。电子邮件正文始终如下。这些行总是以相同的顺序排列。所有线路始终存在。可以提前知道邮箱里的所有名字。
This EMAIL IS ONLY FOR Internal use
Hi
@ABC4: please add the following detail in system (for 12-Jan-2019):
12345_ABC_MakOpt --- 264532154.78
12345_ABC_GAPFee --- 145626547.80
thanks
´ ---------------------------------------- ----------
'开始设置
'------------------------------------------------ ----
Dim wb As Workbook
Dim rngEmailSubject As Range
Dim rngInstrumentName As Range
Dim rngDate As Range
Dim rngAmount As Range
Dim arrFixing() As typFixing
Dim rngValue As Range
Dim rowIdx As Integer
Dim ix As Integer
Dim fixingDate As Date
With wb.Sheets("FixingFromEmail")
Set rngInstrumentName = .Range("instrument.name")
Set rngDate = .Range("Date")
Set rngAmount = .Range("Amount")
rowIdx = rngInstrumentName.Row
ix = 0
Do While True
rowIdx = rowIdx + 1
If Not IsEmpty(.Cells(rowIdx, rngInstrumentName.Column).Value) _
Then
ix = ix + 1
ReDim Preserve arrFixing(1 To ix)
arrFixing(ix).InstrumentName = .Cells(rowIdx, rngInstrumentName.Column).Value
arrFixing(ix).Date = .Cells(rowIdx, rngDate.Column).Value
arrFixing(ix).Amount = .Cells(rowIdx, rngAmount.Column).Value
Else
Exit Do
End If
Loop
End With´
如果你总是在第一行有一个日期，那么你可以用这样简单的东西来得到它：
[0-9]{2}-[A-Za-z]{3}-[0-9]{4}
在 regex101 上试试这个，看看正则表达式的各个部分做了什么
对于另一部分，我想最简单的方法是阅读整行
您的问题过于模糊，无法给出具体答案。我所能提供的只是第一阶段的一些指导。
你需要决定什么是固定的，什么是可变的。
“@ABC4”修复了吗？ “@ABC4：请在系统中添加以下详细信息（对于”已修复？
总是有两条数据线吗？是否有多个数据线，这些是示例？这些行的格式是：
Xxxxxxx space hyphen hyphen hyphen space amount
我首先将文本 body 分成几行。几乎可以肯定，这些行被 Carriage-Return 换行符打断了。测试：
Dim Count As Long
For Each olMail In olItms
Debug.Print Replace(Replace(Mid$(olMailBody, 1, 200), vbCr, "{c}"), vbLf, "{l}" & vbLf)
Count = Count + 1
If Count >= 10 Then
Exit For
End If
Next olMail
输出将类似于十个（最多）副本：
@ABC4: please add the following detail in system (for 12-Jan-2019):{c}{l}
{c}{l}
12345_ABC_MakOpt --- 264532154.78{c}{l}
12345_ABC_GAPFee --- 145626547.80{c}{l}
Are the characters between lines “{c}{l}” or “{l}” or something else?
在下面的代码中，如有必要，将 vbCR & vbLf 替换为 运行 ：
Dim Count As Long
Dim InxL As Long
Dim Lines() As String
For Each olMail In olItms
Lines = Split(olMail.Body, vbCR & vbLf)
For InxL = 0 to UBound(Lines)
Debug.Print InxL + 1 & " " & Lines(InxL)
Next
Count = Count + 1
If Count >= 10 Then
Exit For
End If
Next
输出将类似于十个（最多）副本：
0
1 @ABC4: please add the following detail in system (for 12-Jan-2019):
2
3 12345_ABC_MakOpt --- 264532154.78
4 12345_ABC_GAPFee --- 145626547.80
5
现在您可以将文本 body 视为线条。注意：第一行是数字0。顶部从来没有空行吗？顶部总是有一个空行吗？它有变化吗？我假设顶部总是有一个空行。如果该假设不正确，则需要修改以下代码。
如果第 1 行是“xxxxxxxxxx 日期）：”你可以这样提取日期：
Dim DateCrnt As Date
Dim Pos As Long
DateCrnt = CDate(Left$(Right$(Lines(1), 13), 11))
或
Pos = InStr(1, Lines(1), "(for ")
DateCrnt = CDate(Mid$(Lines(1), Pos + 5, 11))
注意：这两种方法都取决于您在示例中显示的行尾。如果有任何变化，您将需要处理该变化的代码。
您现在可以使用如下代码拆分数据线：
Dim NameCrnt As String
Dim AmtCrnt As Double
For InxL = 3 To UBound(Lines)
If Lines(InxL) <> "" Then
Pos = InStr(1, Lines(InxL), " --- ")
If Pos = 0 Then
Debug.Assert False ' Line not formatted as expected
Else
NameCrnt = Mid$(Lines(InxL), 1, Pos - 1)
AmtCrnt = Mid$(Lines(InxL), Pos + 5)
End If
Debug.Print "Date="& DateCrnt & " " & "Name=" & NameCrnt & " " & "Amount=" & AmtCrnt
End If
Next
输出为：
Date=12/01/2019 Name=12345_ABC_MakOpt Amount=264532154.78
Date=12/01/2019 Name=12345_ABC_GAPFee Amount=145626547.8
显示如何将数据从电子邮件添加到工作表的新部分
这是本节的第二个版本，因为 OP 改变了他们对所需格式的看法。
下面的代码已经过测试，但我创建的假电子邮件看起来像你问题中的那个。因此可能需要进行一些调试。
我创建了一个名为“Fixings”的新工作簿和一个新工作表，其中包含以下标题：
处理我的虚假电子邮件后，工作表如下所示：
行的顺序取决于找到电子邮件的顺序。你可能首先想要最新的。对工作表进行排序超出了此答案的范围。注意：列标题告诉宏要记录哪些值。如果在电子邮件中添加了新行，请添加新的列标题，并且将在不更改宏的情况下保存该值。
除了一个例外，我不会解释我使用的VBA语句，因为很容易在网上搜索“VBA xxxxx”并找到语句xxxxx的规范。例外是使用两个 collections 来保存未决数据。其余的解释描述了我的方法背后的原因。
虽然可能不会持续 6 个月或 12 个月，但要求会发生变化。例如，经理需要不同的标题或不同顺序的列。您无法预料需要进行哪些更改，但可以为更改做好准备。例如，在我的代码顶部我有：
Const ColFixDate As Long = 1
Const ColFixDataFirst As Long = 2
Const RowFixHead As Long = 1
Const RowFixDataFirst As Long = 2
我本可以写 Cells(Row, 1).Value = Date。这有两个缺点：(1) 如果日期列曾经移动过，您必须在代码中搜索访问它的语句，以及 (2) 您必须记住第 1 列或第 2 列或第 3 列中的内容，这使得您的代码更难理解读。我避免将文字用于行号或列号。输入 ColFixDataFirst 而不是 2 的额外努力很快就会得到回报。
我注意到在添加到您的问题的代码中，您使用命名范围来实现相同的效果。 VBA 的一个问题是通常有多种方法可以达到相同的效果。我更喜欢常量，但我们每个人都必须选择自己喜欢的。
我曾在处理许多来自外部的电子邮件和工作簿的部门工作过，其中包含有用的数据，我可以告诉你，它们的格式一直在变化。将有一个额外的空行或现有的一个将被删除。将有额外的数据或现有数据将以不同的顺序排列。作者做出他们认为有用的更改，但很少做任何有用的事情，比如询问接收者是否愿意更改，甚至警告他们更改。我见过的最糟糕的情况是两个数字列颠倒了，几个月都没有注意到。幸运的是，我没有参与其中，因为从我们的系统中撤回错误数据然后导入正确数据是一场噩梦。我会检查我能想到的一切，并拒绝处理与我预期不完全相同的电子邮件。错误信息都写到立即数window，方便开发。您可能想使用 MsgBox 或将它们写入文件。如果邮件处理成功，则不会被删除；它被移动到一个子文件夹中，以便在再次需要时可以检索它。
olMail 是一个 Outlook 常量。不要使用 olMail 或任何其他保留字作为变量名。
我使用了 Session 而不是命名空间。它们应该是等价的，但我曾经遇到过无法诊断的命名空间问题，所以我不再使用它们。
我不对电子邮件进行排序，因为您的代码没有利用对电子邮件进行排序的优势。也许您可以利用按 ReceivedTime 排序的优势，但我可以看到不容易避免的潜在问题。
我以相反的顺序处理电子邮件，因为它们是按位置访问的。例如，如果将电子邮件 5 移动到另一个文件夹，则之前的电子邮件 6 现在是电子邮件 5，并且 For 循环会跳过它。如果以相反的顺序处理电子邮件，您不介意电子邮件 6 现在是电子邮件 5，因为您已经处理过该电子邮件。
如果您不设置持有日期或金额的单元格NumberFormat，它们将根据您所在国家/地区的 Microsoft 默认值显示。我使用了我最喜欢的显示格式。换成你最喜欢的。
在处理完整封电子邮件并提取所需数据之前，代码不会向工作表输出任何内容。这意味着必须存储来自早期数据行的数据，直到处理完所有行。我使用了两个 Collections：PendingNames 和 PendingAmts。这不是我将数据存储在我为自己编写的宏中的方式。我的问题是替代方法更复杂或需要更高级 VBA。
有任何不明白的问题请回来。
Option Explicit
Sub GetFromInbox()
Const ColFixDate As Long = 1
Const ColFixName As Long = 2
Const ColFixAmt As Long = 3
Const RowFixDataFirst As Long = 2
Dim AmtCrnt As Double
Dim ColFixCrnt As Long
Dim DateCrnt As Date
Dim ErrorOnEmail As Boolean
Dim Found As Boolean
Dim InxItem As Long
Dim InxLine As Long
Dim InxPend As Long
Dim Lines() As String
Dim NameCrnt As String
Dim olApp As New Outlook.Application
Dim olFldrIn As Outlook.Folder
Dim olFldrOut As Outlook.Folder
Dim olMailCrnt As Outlook.MailItem
Dim PendingAmts As Collection
Dim PendingNames As Collection
Dim Pos As Long
Dim RowFixCrnt As Long
Dim StateEmail As Long
Dim TempStg As String
Dim WshtFix As Worksheet
Set WshtFix = ThisWorkbook.Worksheets("Fixings")
With WshtFix
RowFixCrnt = .Cells(Rows.Count, ColFixDate).End(xlUp).Row + 1
End With
Set olApp = New Outlook.Application
Set olFldrIn = olApp.Session.GetDefaultFolder(olFolderInbox).Folders("impMail")
Set olFldrOut = olFldrIn.Folders("Processed")
For InxItem = olFldrIn.Items.Count To 1 Step -1
If olFldrIn.Items(InxItem).Class = Outlook.olMail Then
Set olMailCrnt = olFldrIn.Items(InxItem)
If InStr(olMailCrnt.Subject, "SubjectoftheEmail") > 0 Then
Lines = Split(olMailCrnt.Body, vbCr & vbLf)
'For InxLine = 0 To UBound(Lines)
' Debug.Print InxLine + 1 & " " & Lines(InxLine)
'Next
StateEmail = 0 ' Before "please add ..." line
ErrorOnEmail = False
Set PendingAmts = Nothing
Set PendingNames = Nothing
Set PendingAmts = New Collection
Set PendingNames = New Collection
For InxLine = 0 To UBound(Lines)
NameCrnt = "" ' Line is not a data line
Lines(InxLine) = Trim(Lines(InxLine)) ' Remove any leading or trailing spaces
' Extract data from line
If Lines(InxLine) <> "" Then
If StateEmail = 0 Then
If InStr(1, Lines(InxLine), "please add the ") = 0 Then
Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
" The first non-blank line is" & vbLf & _
" " & Lines(InxLine) & vbLf & _
" but I was expecting something like:" & vbLf & _
" @ABC4: please add the following detail in system (for 13-Jan-2019):"
ErrorOnEmail = True
Exit For
End If
TempStg = Left$(Right$(Lines(InxLine), 13), 11)
If Not IsDate(TempStg) Then
Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
" The value I extracted from the ""please add the ...""" & _
" line is """ & vbLf & " " & TempStg & _
""" which I do not recognise as a date"
ErrorOnEmail = True
Exit For
End If
DateCrnt = CDate(TempStg)
StateEmail = 1 ' After "please add ..." line
ElseIf StateEmail = 1 Then
If Lines(InxLine) = "" Then
' Ignore blank line
ElseIf Lines(InxLine) = "thanks" Then
' No more data lines
Exit For
Else
Pos = InStr(1, Lines(InxLine), " --- ")
If Pos = 0 Then
Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
" Data line: " & Lines(InxLine) & vbLf & _
" does not contain ""---"" as required"
ErrorOnEmail = True
'Debug.Assert False
Exit For
End If
NameCrnt = Mid$(Lines(InxLine), 1, Pos - 1)
TempStg = Mid$(Lines(InxLine), Pos + 5)
If Not IsNumeric(TempStg) Then
Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
" Data line:" & Lines(InxLine) & vbLf & _
" value after ""---"" is not an amount"
ErrorOnEmail = True
'Debug.Assert False
Exit For
End If
AmtCrnt = CDbl(TempStg)
End If
End If ' StateEmail
End If ' Lines(InxLine) <> ""
If ErrorOnEmail Then
' Ignore any remaining lines
Exit For
End If
If NameCrnt <> "" Then
' Line was a data line without errors. Save until know entire email is error free
PendingNames.Add NameCrnt
PendingAmts.Add AmtCrnt
End If
Next InxLine
If Not ErrorOnEmail Then
' Output pending rows now know entire email is error-free
With WshtFix
For InxPend = 1 To PendingNames.Count
With .Cells(RowFixCrnt, ColFixDate)
.Value = DateCrnt
.NumberFormat = "d mmm yy"
End With
.Cells(RowFixCrnt, ColFixName).Value = PendingNames(InxPend)
With .Cells(RowFixCrnt, ColFixAmt)
.Value = PendingAmts(InxPend)
.NumberFormat = "#,##0.00"
End With
RowFixCrnt = RowFixCrnt + 1
Next
End With
' Move fully processed email to folder Processed
olMailCrnt.Move olFldrOut
End If
End If ' InStr(olMailCrnt.Subject, "SubjectoftheEmail") > 0
End If ' olFldrIn.Items(InxItem).Class = Outlook.olMail
Next InxItem
Set olFldrIn = Nothing
Set olFldrOut = Nothing
olApp.Quit
Set olApp = Nothing
End Sub
Option Explicit
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("impMail")
Set olItms = olFldr.Items
olItms.Sort "Subject"
For Each olMail In olItms
If InStr(olMail.Subject, "SubjectoftheEmail") > 0 Then
ThisWorkbook.Sheets("Fixings").Cells(2, 2).Value = olMail.Body
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
此代码可帮助我下载电子邮件的整个正文，但我需要单元格中的特定粗体文本。电子邮件正文始终如下。这些行总是以相同的顺序排列。所有线路始终存在。可以提前知道邮箱里的所有名字。
This EMAIL IS ONLY FOR Internal use
Hi
@ABC4: please add the following detail in system (for 12-Jan-2019):
12345_ABC_MakOpt --- 264532154.78
12345_ABC_GAPFee --- 145626547.80thanks
´ ---------------------------------------- ---------- '开始设置 '------------------------------------------------ ----
Dim wb As Workbook
Dim rngEmailSubject As Range
Dim rngInstrumentName As Range
Dim rngDate As Range
Dim rngAmount As Range
Dim arrFixing() As typFixing
Dim rngValue As Range
Dim rowIdx As Integer
Dim ix As Integer
Dim fixingDate As Date
With wb.Sheets("FixingFromEmail")
Set rngInstrumentName = .Range("instrument.name")
Set rngDate = .Range("Date")
Set rngAmount = .Range("Amount")
rowIdx = rngInstrumentName.Row
ix = 0
Do While True
rowIdx = rowIdx + 1
If Not IsEmpty(.Cells(rowIdx, rngInstrumentName.Column).Value) _
Then
ix = ix + 1
ReDim Preserve arrFixing(1 To ix)
arrFixing(ix).InstrumentName = .Cells(rowIdx, rngInstrumentName.Column).Value
arrFixing(ix).Date = .Cells(rowIdx, rngDate.Column).Value
arrFixing(ix).Amount = .Cells(rowIdx, rngAmount.Column).Value
Else
Exit Do
End If
Loop
End With´
如果你总是在第一行有一个日期，那么你可以用这样简单的东西来得到它： [0-9]{2}-[A-Za-z]{3}-[0-9]{4}
在 regex101 上试试这个，看看正则表达式的各个部分做了什么
对于另一部分，我想最简单的方法是阅读整行
您的问题过于模糊，无法给出具体答案。我所能提供的只是第一阶段的一些指导。
你需要决定什么是固定的，什么是可变的。
“@ABC4”修复了吗？ “@ABC4：请在系统中添加以下详细信息（对于”已修复？
总是有两条数据线吗？是否有多个数据线，这些是示例？这些行的格式是：
Xxxxxxx space hyphen hyphen hyphen space amount
我首先将文本 body 分成几行。几乎可以肯定，这些行被 Carriage-Return 换行符打断了。测试：
Dim Count As Long
For Each olMail In olItms
Debug.Print Replace(Replace(Mid$(olMailBody, 1, 200), vbCr, "{c}"), vbLf, "{l}" & vbLf)
Count = Count + 1
If Count >= 10 Then
Exit For
End If
Next olMail
输出将类似于十个（最多）副本：
@ABC4: please add the following detail in system (for 12-Jan-2019):{c}{l}
{c}{l}
12345_ABC_MakOpt --- 264532154.78{c}{l}
12345_ABC_GAPFee --- 145626547.80{c}{l}
Are the characters between lines “{c}{l}” or “{l}” or something else?
在下面的代码中，如有必要，将 vbCR & vbLf 替换为 运行 ：
Dim Count As Long
Dim InxL As Long
Dim Lines() As String
For Each olMail In olItms
Lines = Split(olMail.Body, vbCR & vbLf)
For InxL = 0 to UBound(Lines)
Debug.Print InxL + 1 & " " & Lines(InxL)
Next
Count = Count + 1
If Count >= 10 Then
Exit For
End If
Next
输出将类似于十个（最多）副本：
0
1 @ABC4: please add the following detail in system (for 12-Jan-2019):
2
3 12345_ABC_MakOpt --- 264532154.78
4 12345_ABC_GAPFee --- 145626547.80
5
现在您可以将文本 body 视为线条。注意：第一行是数字0。顶部从来没有空行吗？顶部总是有一个空行吗？它有变化吗？我假设顶部总是有一个空行。如果该假设不正确，则需要修改以下代码。
如果第 1 行是“xxxxxxxxxx 日期）：”你可以这样提取日期：
Dim DateCrnt As Date
Dim Pos As Long
DateCrnt = CDate(Left$(Right$(Lines(1), 13), 11))
或
Pos = InStr(1, Lines(1), "(for ")
DateCrnt = CDate(Mid$(Lines(1), Pos + 5, 11))
注意：这两种方法都取决于您在示例中显示的行尾。如果有任何变化，您将需要处理该变化的代码。
您现在可以使用如下代码拆分数据线：
Dim NameCrnt As String
Dim AmtCrnt As Double
For InxL = 3 To UBound(Lines)
If Lines(InxL) <> "" Then
Pos = InStr(1, Lines(InxL), " --- ")
If Pos = 0 Then
Debug.Assert False ' Line not formatted as expected
Else
NameCrnt = Mid$(Lines(InxL), 1, Pos - 1)
AmtCrnt = Mid$(Lines(InxL), Pos + 5)
End If
Debug.Print "Date="& DateCrnt & " " & "Name=" & NameCrnt & " " & "Amount=" & AmtCrnt
End If
Next
输出为：
Date=12/01/2019 Name=12345_ABC_MakOpt Amount=264532154.78
Date=12/01/2019 Name=12345_ABC_GAPFee Amount=145626547.8
显示如何将数据从电子邮件添加到工作表的新部分
这是本节的第二个版本，因为 OP 改变了他们对所需格式的看法。
下面的代码已经过测试，但我创建的假电子邮件看起来像你问题中的那个。因此可能需要进行一些调试。
我创建了一个名为“Fixings”的新工作簿和一个新工作表，其中包含以下标题：
处理我的虚假电子邮件后，工作表如下所示：
行的顺序取决于找到电子邮件的顺序。你可能首先想要最新的。对工作表进行排序超出了此答案的范围。注意：列标题告诉宏要记录哪些值。如果在电子邮件中添加了新行，请添加新的列标题，并且将在不更改宏的情况下保存该值。
除了一个例外，我不会解释我使用的VBA语句，因为很容易在网上搜索“VBA xxxxx”并找到语句xxxxx的规范。例外是使用两个 collections 来保存未决数据。其余的解释描述了我的方法背后的原因。
虽然可能不会持续 6 个月或 12 个月，但要求会发生变化。例如，经理需要不同的标题或不同顺序的列。您无法预料需要进行哪些更改，但可以为更改做好准备。例如，在我的代码顶部我有：
Const ColFixDate As Long = 1
Const ColFixDataFirst As Long = 2
Const RowFixHead As Long = 1
Const RowFixDataFirst As Long = 2
我本可以写 Cells(Row, 1).Value = Date。这有两个缺点：(1) 如果日期列曾经移动过，您必须在代码中搜索访问它的语句，以及 (2) 您必须记住第 1 列或第 2 列或第 3 列中的内容，这使得您的代码更难理解读。我避免将文字用于行号或列号。输入 ColFixDataFirst 而不是 2 的额外努力很快就会得到回报。
我注意到在添加到您的问题的代码中，您使用命名范围来实现相同的效果。 VBA 的一个问题是通常有多种方法可以达到相同的效果。我更喜欢常量，但我们每个人都必须选择自己喜欢的。
我曾在处理许多来自外部的电子邮件和工作簿的部门工作过，其中包含有用的数据，我可以告诉你，它们的格式一直在变化。将有一个额外的空行或现有的一个将被删除。将有额外的数据或现有数据将以不同的顺序排列。作者做出他们认为有用的更改，但很少做任何有用的事情，比如询问接收者是否愿意更改，甚至警告他们更改。我见过的最糟糕的情况是两个数字列颠倒了，几个月都没有注意到。幸运的是，我没有参与其中，因为从我们的系统中撤回错误数据然后导入正确数据是一场噩梦。我会检查我能想到的一切，并拒绝处理与我预期不完全相同的电子邮件。错误信息都写到立即数window，方便开发。您可能想使用 MsgBox 或将它们写入文件。如果邮件处理成功，则不会被删除；它被移动到一个子文件夹中，以便在再次需要时可以检索它。
olMail 是一个 Outlook 常量。不要使用 olMail 或任何其他保留字作为变量名。
我使用了 Session 而不是命名空间。它们应该是等价的，但我曾经遇到过无法诊断的命名空间问题，所以我不再使用它们。
我不对电子邮件进行排序，因为您的代码没有利用对电子邮件进行排序的优势。也许您可以利用按 ReceivedTime 排序的优势，但我可以看到不容易避免的潜在问题。
我以相反的顺序处理电子邮件，因为它们是按位置访问的。例如，如果将电子邮件 5 移动到另一个文件夹，则之前的电子邮件 6 现在是电子邮件 5，并且 For 循环会跳过它。如果以相反的顺序处理电子邮件，您不介意电子邮件 6 现在是电子邮件 5，因为您已经处理过该电子邮件。
如果您不设置持有日期或金额的单元格NumberFormat，它们将根据您所在国家/地区的 Microsoft 默认值显示。我使用了我最喜欢的显示格式。换成你最喜欢的。
在处理完整封电子邮件并提取所需数据之前，代码不会向工作表输出任何内容。这意味着必须存储来自早期数据行的数据，直到处理完所有行。我使用了两个 Collections：PendingNames 和 PendingAmts。这不是我将数据存储在我为自己编写的宏中的方式。我的问题是替代方法更复杂或需要更高级 VBA。
有任何不明白的问题请回来。
Option Explicit
Sub GetFromInbox()
Const ColFixDate As Long = 1
Const ColFixName As Long = 2
Const ColFixAmt As Long = 3
Const RowFixDataFirst As Long = 2
Dim AmtCrnt As Double
Dim ColFixCrnt As Long
Dim DateCrnt As Date
Dim ErrorOnEmail As Boolean
Dim Found As Boolean
Dim InxItem As Long
Dim InxLine As Long
Dim InxPend As Long
Dim Lines() As String
Dim NameCrnt As String
Dim olApp As New Outlook.Application
Dim olFldrIn As Outlook.Folder
Dim olFldrOut As Outlook.Folder
Dim olMailCrnt As Outlook.MailItem
Dim PendingAmts As Collection
Dim PendingNames As Collection
Dim Pos As Long
Dim RowFixCrnt As Long
Dim StateEmail As Long
Dim TempStg As String
Dim WshtFix As Worksheet
Set WshtFix = ThisWorkbook.Worksheets("Fixings")
With WshtFix
RowFixCrnt = .Cells(Rows.Count, ColFixDate).End(xlUp).Row + 1
End With
Set olApp = New Outlook.Application
Set olFldrIn = olApp.Session.GetDefaultFolder(olFolderInbox).Folders("impMail")
Set olFldrOut = olFldrIn.Folders("Processed")
For InxItem = olFldrIn.Items.Count To 1 Step -1
If olFldrIn.Items(InxItem).Class = Outlook.olMail Then
Set olMailCrnt = olFldrIn.Items(InxItem)
If InStr(olMailCrnt.Subject, "SubjectoftheEmail") > 0 Then
Lines = Split(olMailCrnt.Body, vbCr & vbLf)
'For InxLine = 0 To UBound(Lines)
' Debug.Print InxLine + 1 & " " & Lines(InxLine)
'Next
StateEmail = 0 ' Before "please add ..." line
ErrorOnEmail = False
Set PendingAmts = Nothing
Set PendingNames = Nothing
Set PendingAmts = New Collection
Set PendingNames = New Collection
For InxLine = 0 To UBound(Lines)
NameCrnt = "" ' Line is not a data line
Lines(InxLine) = Trim(Lines(InxLine)) ' Remove any leading or trailing spaces
' Extract data from line
If Lines(InxLine) <> "" Then
If StateEmail = 0 Then
If InStr(1, Lines(InxLine), "please add the ") = 0 Then
Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
" The first non-blank line is" & vbLf & _
" " & Lines(InxLine) & vbLf & _
" but I was expecting something like:" & vbLf & _
" @ABC4: please add the following detail in system (for 13-Jan-2019):"
ErrorOnEmail = True
Exit For
End If
TempStg = Left$(Right$(Lines(InxLine), 13), 11)
If Not IsDate(TempStg) Then
Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
" The value I extracted from the ""please add the ...""" & _
" line is """ & vbLf & " " & TempStg & _
""" which I do not recognise as a date"
ErrorOnEmail = True
Exit For
End If
DateCrnt = CDate(TempStg)
StateEmail = 1 ' After "please add ..." line
ElseIf StateEmail = 1 Then
If Lines(InxLine) = "" Then
' Ignore blank line
ElseIf Lines(InxLine) = "thanks" Then
' No more data lines
Exit For
Else
Pos = InStr(1, Lines(InxLine), " --- ")
If Pos = 0 Then
Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
" Data line: " & Lines(InxLine) & vbLf & _
" does not contain ""---"" as required"
ErrorOnEmail = True
'Debug.Assert False
Exit For
End If
NameCrnt = Mid$(Lines(InxLine), 1, Pos - 1)
TempStg = Mid$(Lines(InxLine), Pos + 5)
If Not IsNumeric(TempStg) Then
Debug.Print "Error with email received " & olMailCrnt.ReceivedTime & vbLf & _
" Data line:" & Lines(InxLine) & vbLf & _
" value after ""---"" is not an amount"
ErrorOnEmail = True
'Debug.Assert False
Exit For
End If
AmtCrnt = CDbl(TempStg)
End If
End If ' StateEmail
End If ' Lines(InxLine) <> ""
If ErrorOnEmail Then
' Ignore any remaining lines
Exit For
End If
If NameCrnt <> "" Then
' Line was a data line without errors. Save until know entire email is error free
PendingNames.Add NameCrnt
PendingAmts.Add AmtCrnt
End If
Next InxLine
If Not ErrorOnEmail Then
' Output pending rows now know entire email is error-free
With WshtFix
For InxPend = 1 To PendingNames.Count
With .Cells(RowFixCrnt, ColFixDate)
.Value = DateCrnt
.NumberFormat = "d mmm yy"
End With
.Cells(RowFixCrnt, ColFixName).Value = PendingNames(InxPend)
With .Cells(RowFixCrnt, ColFixAmt)
.Value = PendingAmts(InxPend)
.NumberFormat = "#,##0.00"
End With
RowFixCrnt = RowFixCrnt + 1
Next
End With
' Move fully processed email to folder Processed
olMailCrnt.Move olFldrOut
End If
End If ' InStr(olMailCrnt.Subject, "SubjectoftheEmail") > 0
End If ' olFldrIn.Items(InxItem).Class = Outlook.olMail
Next InxItem
Set olFldrIn = Nothing
Set olFldrOut = Nothing
olApp.Quit
Set olApp = Nothing
End Sub