Split the subject line to export into separate columns in Excel - vba

Question

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

Answer 1

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