Question

我正在尝试使用我在网上找到的这个脚本从电子邮件中提取数据，并根据我的具体信息进行一些更改：

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 = "C:\Users\Rob\Documents\Excel\ExcelTest.xlsx" '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
rCount = xlSheet.UsedRange.Rows.Count
For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = rCount + 1

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
        If InStr(1, vText(i), "Destination -") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("A" & rCount) = Trim(vItem(1))
        End If
    Next i

    xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
    xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub

我必须从电子邮件中提取的信息显示在下面的BOLD中。

目的地国家 - 宾夕法尼亚州

目的地 - 匹兹堡

英国机场 - 伦敦盖特威克

航空公司 - 联合航空公司

飞行等级 - 高级 - 从499英镑

离开日期 - 2011年7月27日

退货日期 - 10/08/2011

成人 - 2

儿童 - 1

名字 - 安德鲁

姓氏 - Leakey

电话 - 07785 496123 //号码是假的

联系电子邮件 - AmdrewsEmail@Email.org.uk

当我运行代码时，它显示“下标超出范围”，调试器说它正在这一行上发生。

xlSheet.Range("A" & rCount) = Trim(vItem(1))

Answer 1

替换它：

   vItem = Split(vText(i), Chr(58))

用这个：

  vItem = Split(vText(i),"-")

复制到单元格

1 个答案: