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

【问题标题】：Outlook to excel VBA stops searching body after first matchOutlook to excel VBA 在第一次匹配后停止搜索正文
【发布时间】：2014-10-16 18:54:03
【问题描述】：

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

我收到格式相同的电子邮件，其中包含价格和其他信息。这些用于通常有超过 1 行的采购订单。它们采用以下格式：

货品编号：00001

供应商销售订单号：

供应商物料编号：

SAP 物料编号：

供应商描述：

SAP 描述：

供应商数量：30.000 EA

SAP 数量：30.000 EA

数量计量单位：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

数量计量单位：EA

供应商价格：1 个 EA 3.90 美元

SAP 价格：1 个 EA 3.90 美元

供应商交货日期：20.09.2014

SAP 交付日期 : 20.09.2014

行动请求：

数量和请求日期都与采购订单匹配。项目 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

【问题讨论】：

  • 你确定它只是拉第一个还是最后一个？
  • 它会拉出第 1 行项目，然后不会在电子邮件的其余部分中搜索与该字符串匹配的其他可能匹配项。其中一些有 10 多个行项目，这仅将第 1 行导出到 excel

标签： excel vba email outlook extract


【解决方案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 语句）。

【讨论】：

  • 它仍然试图将它全部写入第一行，我可以看到它以超快的速度闪烁覆盖它自己 @jbaker2160
  • 我为此创建了一个测试版本，它对我来说效果很好。我唯一建议的另一件事是将rCount = xlSheet.UsedRange.Rows.Count + 1 直接移动到Set xlSheet = xlWB.Sheets("Sheet1") 下。这很少会导致问题，但它可能会发生。
  • 现在让我试试@jbarker2160
  • 它把它们都放在第 2 行，并且仍然在写它自己。在我的第二台显示器上打开电子表格后，我可以看到它们以超快的速度闪烁。我希望我对 vba 有更多的了解。 @jbarker2160 我在 excel/office 2010 中
  • 刚刚想到了一些东西，必须检查哪些参考才能使其工作？ @jbarker2160
猜你喜欢
  • 2012-02-04
  • 2018-06-27
  • 1970-01-01
  • 2015-07-17
  • 2014-12-04
  • 2022-12-05
  • 1970-01-01
  • 1970-01-01
  • 2023-01-13
相关资源
最近更新 更多
热门标签
Java Python linux javascript Mysql C# Docker 算法 前端 SpringBoot Redis Vue spring 设计模式 .net core .net kubernetes c++ 数据库 数据结构 大数据 js 机器学习 微服务 Android Go 程序员 面试 JVM ASP.net core 云原生 人工智能 后端 PHP git CSS golang k8s Nginx Django mybatis 深度学习 多线程 React 架构 devops 爬虫 云计算 Spring Boot LeetCode