separating outlook subject line into columns

[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