从电子邮件复制线到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中，所以任何帮助非常感谢。

更新： 我想出了如何以我想要的方式提取它，但它是sl and而不动态的。有时候有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