Copy lines from email to Excel into specific array - excel

Question

I am needing to copy some data from emails into a spreadsheet with a VBA, here is how the data is formatted in the email:
Items/Cost:
Item Description 1: $38.88
Quantity: 1
Item Description 2: $39.99
Quantity: 1
The Item Description is always different. Here is how I would like the output to be formatted when copied to Excel:
And here is my current code that I've tried:
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
Also I'm no expert at VB so any help is greatly appreciated.
UPDATE:
I figured out how to extract it the way I want to but it's sloppy and not dynamic. Sometimes there are 2 items and sometimes 5, so i need it to be adaptable. Can someone help me clean it up by chance?

Answer 1

Try the following
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