Consulting

Results 1 to 8 of 8

Thread: separating outlook subject line into columns

  1. #1

    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.

    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

  2. #2
    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
    Last edited by gmayor; 06-27-2015 at 12:20 AM.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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

  4. #4
    Change the line to
    .Range("D" & i + 1).Value = vSubject(2)
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    Thanks gmayor for all your help.

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

  6. #6
    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?

  7. #7
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •