电子邮件正文中的“Purchase Order:”后面是一个整数。
所有电子邮件都遵循此格式。 http://i.stack.imgur.com/1Ck9Q.jpg
该数字将粘贴到Excel电子表格的下一个空行中。
我的桌面上有一个名为“test”的电子表格来试试这个。
我尝试过使用Google发现的4到5个不同的VBA代码而没有运气。
答案 0 :(得分:1)
代码进入Outlook而不是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