Outlook to excel VBA在第一次匹配后停止搜索正文

Question

我写了一段代码将数据从outlook中提取到excel中，它80%的工作:)它确实提取信息，但不是从整个电子邮件中提取信息。

我收到相同格式的电子邮件，上面有价格和其他信息。这些是针对通常超过1行的采购订单。它们的格式如下：

邮品编号: 00001

供应商销售订单号：

供应商物料编号：

SAP物料编号：

供应商描述：

SAP描述：

供应商数量: 30.000个EA

SAP数量: 30.000个EA

数量单位: EA

供应商交付日期:2014.20.09.2014

SAP交付日期:2014.20.09.2014

操作请求：

以下详细信息与PO行项目00001不匹配

销售价:1个EA 0.00美元

SAP价格: 0.01美元/1 EA

邮品编号: 00002

供应商销售订单号：

供应商物料编号：

SAP物料编号：

供应商描述：

SAP描述：

供应商数量: 70.000个EA

SAP数量: 70.000个EA

数量单位: EA

卖家价格:1个EA 3.90美元

SAP价格:1个EA 3.90美元

供应商交付日期:2014.20.09.2014

SAP交付日期:2014.20.09.2014

操作请求：

数量和请求日期都与采购订单匹配。项目00002

正如您从代码中看到的，我从这些具有相同开头字符串的电子邮件中提取了多个内容。在提取第一行之后，代码将移动到下一封电子邮件，而不会搜索电子邮件的整个正文以寻找进一步的匹配。我该如何解决这个问题呢？卡住:)

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

Answer 1

代码：

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语句)。