Create dynamic Excel column from outlook email

Question

Everyday I receive emails like this

ID | Name |  Price | QTY | Valid
 1 | ABC  | 100.50 |   5 | Y
 2 | XYZF |  28.34 |   8 | Y

I then copy the content of my email to an excel spreadsheet that I have.

Now what I want to achieve is run a Macro that will read this email and

1. Create the columns so ID, Name, Price, QTY and Valid
2. apply the valid values under the right column.

Is this achievable?

From my limited knowledge I have a macro which extracts the whole outlook message but how do I make them into columns and then apply the correct values to correct columns?

Macro

Sub ExportToExcel()
    On Error GoTo ErrHandler

    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet

    Dim rng As Excel.Range
    Dim strSheet As String
    Dim strPath As String

    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer

    Dim msg As Outlook.MailItem
    Dim nms As Outlook.NameSpace
    Dim fld As Outlook.MAPIFolder

    Dim itm As Object
    strSheet = "test.xlsx"
    strPath = "C:\test\"
    strSheet = strPath & strSheet

    Debug.Print strSheet

    'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder

    'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.DefaultItemType <> olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    End If

    'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Workbooks.Open (strSheet)
    Set wkb = appExcel.ActiveWorkbook
    Set wks = wkb.Sheets(1)
    wks.Activate
    appExcel.Application.Visible = True

    'Copy field items in mail folder.
    For Each itm In fld.Items
        intColumnCounter = 1
        Set msg = itm
        intRowCounter = intRowCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.To
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.SenderEmailAddress
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Subject
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.SentOn
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.ReceivedTime
    Next itm

    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing

    Exit Sub
ErrHandler:  
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
    Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
    End If

    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
End Sub

Email example

Answer 1

• You can delete the lines starting with Set appExcel = Nothing ending with Set itm = Nothing. They are useless, as far as at the end of the "macro", the routine variables are set to Nothing anyhow.

• It is a good idea not to use Integer in VBA - Why Use Integer Instead of Long?

• This line Set nms = Application.GetNamespace("MAPI") could be written like this, to make the code a bit more robust: Set nms = Outlook.Application.GetNamespace("MAPI")

At the end, your question is more like "how can I extract a string from this":

ID | Name |  Price | QTY | Valid
 1 | ABC  | 100.50 |   5 | Y
 2 | XYZF |  28.34 |   8 | Y

to some Excel table. To get the corresponding string, you have to use the .Body. See yourself, changing the loop:

For Each itm In fld.Items
    lines = Split(itm.Body, vbCrLf)
    For Each line In lines
        If Len(line) - Len(Replace(line, "|", "")) > 3 Then
            Cells(Row, Column) = Split(line, "|")(0)
            Cells(Row, Column + 1) = Split(line, "|")(1)
            Cells(Row, Column + 2) = Split(line, "|")(2)
            Cells(Row, Column + 3) = Split(line, "|")(3)
        End If
    Next
Next itm

Once you have 4 or more | per line, then you do Split(line,"|") and you pass each one of the elements of the array to the corresponding column.