我编写了一个代码，用于将数据从outlook提取到excel，并且其80％正在工作:)它确实提取信息，但不是来自整个电子邮件。
我会收到相同格式的电子邮件，其中包含定价和其他信息。这些是针对通常超过1行的采购订单。它们采用以下格式：
项目编号：00001
供应商销售订单编号：
供应商物料编号：
SAP物料编号：
供应商描述：
SAP描述：
供应商数量：30.000 EA
SAP数量：30.000 EA
数量UOM：EA
供应商交货日期：20.09.2014
SAP交付日期：20.09.2014
行动要求：
以下详细信息与采购订单项目00001
不符供应商价格：1 EA <0.00美元
SAP价格：1 EA <0.01美元
项目编号：00002
供应商销售订单编号：
供应商物料编号：
SAP物料编号：
供应商描述：
SAP描述：
供应商数量：70.000 EA
SAP数量：70.000 EA
数量UOM：EA
供应商价格：1 EA的3.90美元
SAP价格：1 EA的3.90美元
供应商交货日期：20.09.2014
SAP交付日期：20.09.2014
行动要求：
数量和请求日期均与PO匹配。项目00002
从代码中可以看出，我从这些具有相同开头字符串的电子邮件中提取了多个内容。在它拉出第1行之后，代码将移动到下一封电子邮件，而不会搜索整个电子邮件正文以进一步匹配。我怎样才能解决这个问题？被困：）
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "Excel filepath here" 'the path of the workbook
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process each selected record
For Each olItem In Application.ActiveWindow.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.UsedRange.Rows.Count + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
rCount = rCount
If InStr(1, vText(i), "Purchase Order :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Vendor :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Item Number :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Vendor Quantity :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "SAP Quantity :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Quantity UOM :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Vendor Price :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "SAP Price :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Vendor Delivery Date :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("I" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "SAP Delivery Date :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("J" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("K" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("L" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("M" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("N" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("O" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("Q" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
答案 0 :(得分：0)
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Object
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim j As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "Excel filepath here" 'the path of the workbook
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process each selected record
For j = 1 To Application.ActiveExplorer.Selection.Count
Set olItem = Application.ActiveExplorer.Selection.Item(j)
If olItem.Class = 43 Then
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.UsedRange.Rows.Count + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Purchase Order :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Vendor :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Item Number :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Vendor Quantity :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "SAP Quantity :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Quantity UOM :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Vendor Price :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "SAP Price :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Vendor Delivery Date :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("I" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "SAP Delivery Date :") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("J" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("K" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("L" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("M" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("N" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("O" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Text here") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("Q" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
rCount = rCount + 1
End If
Next j
xlWB.Close SaveChanges:=True
If bXStarted Then
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
这应该有效。出于某种原因，如果在您的选择中遇到非邮件项目，Outlook将简单地停止执行而不会出现错误。
复制并粘贴整个内容（甚至是Dim语句）。