separating outlook subject line into columns

[spittingfire]

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 (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


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

[gmayor]

The following should work:


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

[spittingfire]

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 :)

[gmayor]

Change the line to

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

[spittingfire]

Thanks gmayor for all your help.

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

[spittingfire]

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?

[gmayor]

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.



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

[spittingfire]

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