separting outlook subject line into columns - vba

Question

I have the below code that I am trying to modify to split a subject line into to six columns to view in Excel.
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
SLWP Moncton | Cable Service Eng. | 21-Jul-15 | Shift End: 0:00 | Leave Time: entire day | SLWP (Unpaid)
So in total 7 columns I plan to leave is below.
Sender
Location
LOB
Date
Shift End Time
Shift Leave Time
Leave Type
In it's current state as you can see it only produces two columns and I do not know how to break the subject line apart.
Any help will be most appreciated.
Thanks

Answer 1

Use Split.
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

Answer 2

I was able to solve the issue
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 = 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