separating outlook subject line into columns

I have the below code that I am trying to modify to split a subject line into to six columns to view in Excel.

Code:

---

Sub subject2excel()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"

For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body

xlobj.Range("a" & i + 1).Value = myitem.Sender
xlobj.Range("b" & i + 1).Value = myitem.Subject


Next
End Sub

---

My data is in the below format (please note that this is subject line information only - the body of the email is not required)

SLWP Ottawa | Sales Eng. | 26-Jun-15 | Shift End: 21:00 | Leave Time: entire day | SLWP (Unpaid)
SLWP Brampton | Sales Eng. | 26-Jun-15 | Shift End: 19:00 | Leave Time: entire day | SLWP (Unpaid)
SLWP Ottawa | Sales Eng. | 26-Jun-15 | Shift End: 16:00 | Leave Time: 12:15 | SLWP (Unpaid)

I will like to have it split into the following column headers:

Column A will be - Sender
Column B will be - Location
Column C will be - LOB
Column D will be - Date
Column E will be - Shift End Time
Column F will be - Requested Leave Time
Column G will be - Paid / Unpaid

Any help will be most appreciative.

I also tried to modify the code with the below but still to no avail

Code:

---

Sub subject2excel()

Dim myOlApp As Outlook.Application
Dim myFolder As folder
Dim xlobj As Object
Dim i As Long
Dim j As Long
Dim myitem As Object

Dim Words() As String

'On Error Resume Next
Set myOlApp = Outlook.Application
'Set myNameSpace = myOlApp.GetNamespace("mapi")
Set myFolder = myOlApp.ActiveExplorer.currentFolder
Set xlobj = CreateObject("excel.application.14")

xlobj.Visible = True
xlobj.Workbooks.Add

'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"

For i = 1 To myFolder.Items.count

    Set myitem = myFolder.Items(i)

    If TypeOf myitem Is MailItem Then
        'msgText = myitem.body

        xlobj.Range("a" & i + 1).Value = myitem.Sender
        'xlobj.Range("b" & i + 1).Value = myitem.Subject

        Words = Split(myitem.Subject, " | ")

        For j = 0 To UBound(Words)
            Debug.Print Words(j)
        Next j

    End If

Next i

exitRoutine:
    Set myOlApp = Nothing
    Set myFolder = Nothing
    Set xlobj = Nothing
    Set myitem = Nothing

End Sub

---

The following should work:

Code:

---

Sub subject2excel()

Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim olNS As Outlook.NameSpace
Dim xlApp As Object
Dim xlWB As Object
Dim i As Long
Dim j As Long
Dim vSubject As Variant


    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0        'err_Handler
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Add
    'Set Heading
    With xlWB.Sheets(1)
        .Range("A" & 1).Value = "Sender"
        .Range("B" & 1).Value = "Location"
        .Range("C" & 1).Value = "LOB"
        .Range("D" & 1).Value = "Date"
        .Range("E" & 1).Value = "Shift End Time"
        .Range("F" & 1).Value = "Requested Leave Time"
        .Range("G" & 1).Value = "Paid/Unpaid"
    End With
    'Fill sheet
    Set olNS = GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    For i = 1 To olFolder.Items.Count
        Set olItem = olFolder.Items(i)
        If InStr(1, olItem.Subject, "|") > 0 Then
            vSubject = Split(olItem.Subject, "|")
            With xlWB.Sheets(1)
                .Range("A" & i + 1).Value = olItem.Sender
                .Range("B" & i + 1).Value = vSubject(0)
                .Range("C" & i + 1).Value = vSubject(1)
                .Range("D" & i + 1).Value = CDate(vSubject(2))
                .Range("E" & i + 1).Value = Trim(Mid(vSubject(3), InStr(1, vSubject(3), Chr(58)) + 1))
                .Range("F" & i + 1).Value = Trim(Mid(vSubject(4), InStr(1, vSubject(4), Chr(58)) + 1))
                .Range("F" & i + 1).HorizontalAlignment = -4152 'align right
                .Range("G" & i + 1).Value = Replace(Trim(Mid(vSubject(5), InStrRev(vSubject(5), Chr(40)) + 1)), Chr(41), "")
            End With
        End If
    Next i
    xlWB.Sheets(1).UsedRange.Columns.Autofit
exitRoutine:
    Set olFolder = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
err_Handler:
    GoTo lbl_Exit
End Sub

---

Thanks a million gmayor

It works as expected however it seems to be having issues with months written in French

See the below example with the dates highlighted.

It code is failing at the below highlighted date in the CDate(vSubject(2)) part of the code with a Type MisMatch error.

SLWP Montreal | Care Help Desk Fr. | 27-juin-15 | Shift End: 16:00 | Leave Time: entire day | SLWP (Unpaid)

In contrast if written as

SLWP Montreal | Care Help Desk Fr. | 27-jun-15 | Shift End: 16:00 | Leave Time: entire day | SLWP (Unpaid)

no issues.

Is there anyway around this issue?

Thanks again for your help :)

Change the line to

Code:

---

.Range("D" & i + 1).Value = vSubject(2)

---

Thanks gmayor for all your help.

Now it truly works the way I want it to work.

Hi Gmayor,

First of all I apologize if this is not the correct process.

I know that I have already marked this as solved and by all intent and purposes it is, however I am wondering if I want to modify the code to include the sub-folders of the folder that I select how will I go about doing that?

My reply seems to have got lost, so let's try again. Processing the sub folders is simple enough. It just requires them to be added to a collection and then process the collection e.g. as follows. I have separated the message processing from the folder processing to make it easier to follow.

Code:

---

Option Explicit

Sub subject2excel()
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim subFolder As Folder
Dim olNS As Outlook.NameSpace
Dim xlApp As Object
Dim xlWB As Object
Dim i As Long
Dim j As Long
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Add
    'Set Headings
    With xlWB.Sheets(1)
        .Range("A" & 1).Value = "Sender"
        .Range("B" & 1).Value = "Location"
        .Range("C" & 1).Value = "LOB"
        .Range("D" & 1).Value = "Date"
        .Range("E" & 1).Value = "Shift End Time"
        .Range("F" & 1).Value = "Requested Leave Time"
        .Range("G" & 1).Value = "Paid/Unpaid"
    End With
    'Fill sheet
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.PickFolder
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        ProcessFolder olFolder, xlWB
        For Each subFolder In olFolder.folders
            cFolders.Add subFolder
        Next subFolder
    Loop
    xlWB.Sheets(1).UsedRange.Columns.Autofit
lbl_Exit:
    Set olFolder = Nothing
    Set subFolder = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Exit Sub
err_Handler:
    GoTo lbl_Exit
End Sub

Sub ProcessFolder(iFolder As Folder, xlWB As Object)
Dim i As Long
Dim olItem As Outlook.MailItem
Dim vSubject As Variant
Dim NextRow As Long
    For i = 1 To iFolder.Items.Count
        NextRow = xlWB.Sheets(1).Range("A" & xlWB.Sheets(1).Rows.Count).End(-4162).Row + 1
        Set olItem = iFolder.Items(i)
        If InStr(1, olItem.Subject, "|") > 0 Then
            vSubject = Split(olItem.Subject, "|")
            With xlWB.Sheets(1)
                .Range("A" & NextRow).Value = olItem.Sender
                .Range("B" & NextRow).Value = vSubject(0)
                .Range("C" & NextRow).Value = vSubject(1)
                .Range("D" & NextRow).Value = vSubject(2)
                .Range("E" & NextRow).Value = Trim(Mid(vSubject(3), InStr(1, vSubject(3), Chr(58)) + 1))
                .Range("F" & NextRow).Value = Trim(Mid(vSubject(4), InStr(1, vSubject(4), Chr(58)) + 1))
                .Range("F" & NextRow).HorizontalAlignment = -4152        'align right
                .Range("G" & NextRow).Value = Replace(Trim(Mid(vSubject(5), _
                                                            InStrRev(vSubject(5), Chr(40)) + 1)), Chr(41), "")
            End With
        End If
    Next i
lbl_Exit:
    Set olItem = Nothing
    Exit Sub
End Sub

---

Thanks again gmayor and much appreciated with the explanation and separation. Looking at it now makes sense to me.