首页 文章

将结构化文本块中的数据从 Outlook 邮件复制到 Excel 工作表

提问于
浏览
-2

电子邮件正文中的“购买顺序:”后面有一个整数。

所有电子邮件都遵循这种格式。 http://i.stack.imgur.com/1Ck9Q.jpg

该数字将粘贴到 Excel 电子表格的下一个空行中。

我在桌面上有一个名为“ test”的电子表格可以尝试使用。

我已经尝试使用 Google 找到了大约 4 或 5 种不同的 VBA 代码,但没有运气。

1 回答

  • 1

    这里显示了解决此常见问题的方法。 http://social.msdn.microsoft.com/Forums/en-US/f1ab97d9-8fef-46cc-bbe0-e597370ed1c2/export-content-from-outlook-2010-emails-to-excel-spreadsheet?forum=isvvba

    该代码进入 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
    

相关问题