将电子邮件中的行复制到 Excel 中

Question

我需要使用 VBA 将电子邮件中的一些数据复制到电子表格中，以下是电子邮件中数据的格式：

物品/费用：

项目描述 1 ：38.88 美元

数量：1

项目描述 2 ：39.99 美元

数量：1

项目描述总是不同的。 这是我希望在复制到 Excel 时格式化输出的方式：

这是我尝试过的当前代码：

Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim xl
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
Dim rTime As Date
Const strPath As String = "C:\Tracking.xlsx" 'the path of the workbook

If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
EndIf
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")
xlWB.Sheets(1).Cells.Delete

'Process each selected record
 rCount = xlSheet.UsedRange.Rows.Count
 'cCount = xlSheet.UsedRange.Columns.Count
  For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    rTime = Format(olItem.ReceivedTime, "mmmm d, yyyy")
    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(vText(i), "Items/Cost:") Then
            'ParseText = vText(i + 1) & vbCrLf
            xlSheet.Range("A" & rCount) = Trim(vText(2))
            vItem = Split(vText(4), Chr(58))
            xlSheet.Range("B" & rCount) = Trim(vItem(1))
            xlSheet.Range("A" & rCount + 1) = Trim(vText(6))
            vItem = Split(vText(8), Chr(58))
            xlSheet.Range("B" & rCount + 1) = Trim(vItem(1))
            xlSheet.Range("A" & rCount + 2) = Trim(vText(10))
            vItem = Split(vText(12), Chr(58))
            xlSheet.Range("B" & rCount + 2) = Trim(vItem(1))
            xlSheet.Range("A" & rCount + 3) = Trim(vText(14))
            vItem = Split(vText(16), Chr(58))
            xlSheet.Range("B" & rCount + 3) = Trim(vItem(1))
            xlSheet.Range("A" & rCount + 4) = Trim(vText(18))
            vItem = Split(vText(20), Chr(58))
            xlSheet.Range("B" & rCount + 4) = Trim(vItem(1))
            
        End If
                
    Next i
    xlWB.Save
Next olItem


Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing


End Sub

我也不是 VB 专家，所以非常感谢任何帮助。

更新：我想出了如何以我想要的方式提取它，但它很草率而且不是动态的。 有时有 2 个项目，有时有 5 个，所以我需要它具有适应性。 有人可以帮我清理一下吗？

Answer 1

尝试以下

Option Explicit
Sub EmailToCsv()
    Dim olItem As Outlook.MailItem
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim i As Long
    Dim RowCount As Long
    Dim xlStarted As Boolean
    Dim FilePath As String

    '// Update File location
    FilePath = "C:\Temp\Tracking.xlsx"

    '// Process Selections
    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")
        xlStarted = True
    End If

    On Error GoTo 0
    '// Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(FilePath)
    Set xlSheet = xlWB.Sheets("Sheet1")

    '// Process each selected record
    For Each olItem In Application.ActiveExplorer.Selection
        sText = olItem.Body
        vText = Split(sText, Chr(13)) ' Chr(13)) carriage return

        '// Find the next empty line of the worksheet
        RowCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
        RowCount = RowCount + 1

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

            '// Item Description 1
            If InStr(1, vText(i), "Item Description 1:") > 0 Then
                vItem = Split(vText(i), Chr(58)) ' Chr(58) ":"
                xlSheet.Range("A" & RowCount) = "Item Description 1: " & Trim(vItem(1))
            End If

            '// Quantity
            If InStr(1, vText(i), "Quantity:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & RowCount) = Trim(vItem(1))
            End If

            '// Item Description 2
            If InStr(1, vText(i), "Item Description 2:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & RowCount + 1) = "Item Description 2: " & Trim(vItem(1))
            End If

            '// Quantity
            If InStr(1, vText(i), "Quantity:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & RowCount + 1) = Trim(vItem(1))
            End If

        Next i
    Next olItem

    '// SaveChanges & Close
    xlWB.Close SaveChanges:=True
    If xlStarted Then
        xlApp.Quit
    End If

    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set olItem = Nothing
 End Sub