CODEWITHSUNDEEP
vbaoutlookexport-to-excel
BradP
BradP

Reputation: 77

Split the subject line to export into separate columns in Excel

I have code which exports the subject of emails from a folder I choose to an Excel workbook. I need the text after the first 'space' in the subject to be exported to another column (column C preferably). Below are a couple of examples of what the subject lines look like:

" 321-654321 APPROVED With more words to follow "

and

" APR#987-123456 CONTIGENT With More text to follow "

I want to have the number (or) everything before the first space in the subject in one column and everything after the number, first space, in a different column.

here is an example of the output I would like to have

Column A - Column B - Column C

XXX-XXXXX - DateOf Email - Status of the incident

Here is the code I'm currently using, I believe I found this macro on Stackoverflow. Also, Can't I skip having the user choose the folder and put what folder I want this macro to act on inside the code?

   Sub ExportToExcel()

    On Error GoTo ErrHandler

    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim strSheet As String
    Dim strPath As String
    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer
    Dim msg As Outlook.MailItem
    Dim nms As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object

    strSheet = "spreadhsheet.xlsx"
    strPath = "C:\MyOutlookMacro\"
    strSheet = strPath & strSheet

    Debug.Print strSheet
    'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder
    'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.DefaultItemType <> olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    End If
    'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Workbooks.Open (strSheet)
    Set wkb = appExcel.ActiveWorkbook
    Set wks = wkb.Sheets(1)
    wks.Activate
    appExcel.Application.Visible = True
    'Copy field items in mail folder.
    For Each itm In fld.Items
        intColumnCounter = 1
        Set msg = itm
        intRowCounter = intRowCounter + 3
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Subject
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.SentOn
    Next itm

    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    Exit Sub

    ErrHandler: If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
    Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
    End If

    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    End Sub

-------------------------------



Sub ExportToExcel()

    On Error GoTo ErrHandler

    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim strSheet As String
    Dim strPath As String
    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer
    Dim msg As Outlook.MailItem
    Dim nms As Outlook.NameSpace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object
    Dim Words As String

    strSheet = "spreadhsheet.xlsx"
    strPath = "C:\MyOutlookMacro\"
    strSheet = strPath & strSheet

    Debug.Print strSheet
    'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder
    'Set fld = Set fld = myNamespace.GetDefaultFolder(olFolderInbox).Folders("SpreadsheetItems")

  'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.DefaultItemType <> olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    End If


   'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Workbooks.Open (strSheet)
    Set wkb = appExcel.ActiveWorkbook
    Set wks = wkb.Sheets(1)
    wks.Activate
    appExcel.Application.Visible = True


   'Copy field items in mail folder.


For Each itm In fld.Items
    intColumnCounter = 1
    Set msg = itm

    Words = Split(msg.Subject, " ")

    intRowCounter = intRowCounter + 3

    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Words(0)

    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.SentOn

    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Words(2)

Next itm

    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    Exit Sub

ErrHandler:     If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
    Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
    End If

    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    End Sub

** I'm getting "Compile Error: Expected Array @ rng.Value = Words(0) **

Upvotes: 1

Views: 2839

Answers (1)

niton
niton

Reputation: 9179

Re: Split the subject

Use Split

Dim Words() As String ' not Dim Words as String

For Each itm In fld.Items
    intColumnCounter = 1
    Set msg = itm

    Words = Split(msg.Subject, " ")

    intRowCounter = intRowCounter + 3

    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Words(0)

    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.SentOn

    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Words(2)

Next itm

Re: "... skip having the user choose the folder and put what folder I want ..."

If the Source folder is in the default Inbox then

Set fld = myNamespace.GetDefaultFolder(olFolderInbox).Folders.("Source")

Add as many .Folders("...") as necessary if the Source folder is deeper.

If the Source folder is not in the default Inbox then Get reference to additional Inbox

Upvotes: 1

Related Questions