Copy data in a structured text block from Outlook message to Excel sheet

问题

An integer number follows "Purchase Order:" in the email body.

All emails follow this format. http://i.stack.imgur.com/1Ck9Q.jpg

The number is to be pasted into the next empty row of the Excel spreadsheet.

I have a spreadsheet on my desktop named "test" to try this with.

I've tried about 4 or 5 different VBA codes I found using Google with no luck.

回答1:

A method to address this frequently asked question is shown here. http://social.msdn.microsoft.com/Forums/en-US/f1ab97d9-8fef-46cc-bbe0-e597370ed1c2/export-content-from-outlook-2010-emails-to-excel-spreadsheet?forum=isvvba

The code goes into Outlook not Excel.

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:\path\desktop\test.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
For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = xlSheet.UsedRange.Rows.Count

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1

        rCount = rCount + 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

        ' Where more data is to be extracted add more of these lines.
        'If InStr(1, vText(i), "Second label:") > 0 Then
        '    vItem = Split(vText(i), Chr(58))
        '    xlSheet.Range("B" & rCount) = Trim(vItem(1))
        'End If

        'If InStr(1, vText(i), "Third label:") > 0 Then
        '    vItem = Split(vText(i), Chr(58))
        '    xlSheet.Range("C" & 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

来源：https://stackoverflow.com/questions/25140954/copy-data-in-a-structured-text-block-from-outlook-message-to-excel-sheet