Outlook 365 VBA Script to move mails with ticket number in subject

[Dooringboom]

Hi there.
To start of I have limited VBA knowledge in Excel and this is my first run at trying VBA in Outlook.
Our company makes use of tickets related to issues orders requests ect, and this mails is filling up an inbors very quickly.
I am looking for a way to move mails which contains a ticket number (For example: ABC- in the subject line to a sub folder (With the same name as the ticket number) in the inbox.
Ideally A function that does this will be great then I can only send a list of values (That will expand over time) to the function and the function will sort out the move of various mails.

Any help or advice will be greatly appreciated.

[gmayor]

In order to do this it is necessary to identify exactly how the subjects containing the ticket numbers are formatted so as to be able to differentiate them from other e-mails that might have numbers in the subject that are not ticket numbers. As for the sub folders, if this also relates to the subject then how is the folder data to be identified? Do the folders exist or are they to be created (some e-mail servers do not allow the creation of sub folders from VBA when access is not via POP). As for the folders themselves are these Outlook folders or Windows folders.

There are too many unknowns to suggest a way forward. You could start by posting some actual subjects.

[Dooringboom]

The ticket number will be three characters (ABC) with a "-" followed by a running number sequence. For example ABC-892576. My Idea is send specific ticket numbers to a function, and then the mail containing that specific ticket number in subject line will need to be move to the same named folder (ABC-892576). I will manually create each folder before I add the ticket number to the list of values that I want to send to the function.

[gmayor]

As I anticipated, establishing whether the particular ticket number sequence exists in the subjects of a batch of e-mails that may or may not have such a sequence, and then extracting that ticket number was always going to be problematical. But for the hot and humid weather which has kept me at my desk, instead of doing something more useful, I would probably have given up.

However the following seems to work, and while I have not exhausted every conceivable e-mail subject construction, I have run it on my inbox of many items and it picks out only those that have letters and numbers in the format requested. The process also creates the folders if not present.

The macro looks for subjects that include values like ABC-892576 and not (ABC-892576) nor ABC - 892576
It puts the matching e-mails in a sub folder of Inbox named like ABC-892576 and not (ABC-892576)
If you want the brackets I'll let you edit them in.



Option Explicit
'Graham Mayor - http://www.gmayor.com - Last updated - 24 Jul 2017
Private Type TicketSettings
Ticket As String
Found As Boolean
End Type

Sub MoveTickets()
'Graham Mayor - http://www.gmayor.com - Last updated - 24 Jul 2017
Dim oFolder As Folder
Dim oSubFolder As Folder
Dim oItem As Object
Dim vSubject As Variant
Dim sFolder As String
Dim bFound As Boolean
Dim lngCount As Long
Dim oSettings As TicketSettings

Set oFolder = Session.GetDefaultFolder(olFolderInbox)
For lngCount = oFolder.Items.Count To 1 Step -1
Set oItem = oFolder.Items(lngCount)
oSettings = TicketItem(oItem)
bFound = False
If oSettings.Found = True Then
sFolder = Trim(oSettings.Ticket)
For Each oSubFolder In oFolder.folders
If oSubFolder.Name = sFolder Then
bFound = True
Exit For
End If
Next oSubFolder
If Not bFound = True Then
Set oSubFolder = oFolder.folders.Add(sFolder)
End If
oItem.Move oSubFolder
End If
DoEvents
Next lngCount
lbl_Exit:
Set oFolder = Nothing
Set oSubFolder = Nothing
Set oItem = Nothing
Exit Sub
End Sub

Private Function TicketItem(olItem As Object) As TicketSettings
'Graham Mayor - http://www.gmayor.com - Last updated - 24 Jul 2017
Dim strText As String
Dim i As Integer, j As Integer, iLen As Integer
Dim vSets As TicketSettings

On Error Resume Next
strText = olItem.Subject
i = InStr(1, strText, "-")
If i > 4 Then
strText = Right(strText, Len(strText) - (i - 4))
End If
iLen = Len(strText)
For j = 5 To iLen
If Not IsNumeric(Mid(strText, j, 1)) = True Then
Exit For
End If
Next j
strText = Trim(Left(strText, j))
If InStr(1, strText, "-") > 0 And _
j > 5 And _
Mid(strText, 1, 1) = UCase(Mid(strText, 1, 1)) And _
IsNumeric(Mid(strText, 1, 1)) = False And _
Mid(strText, 2, 1) = UCase(Mid(strText, 2, 1)) And _
IsNumeric(Mid(strText, 2, 1)) = False And _
Mid(strText, 3, 1) = UCase(Mid(strText, 3, 1)) And _
IsNumeric(Mid(strText, 3, 1)) = False Then
With vSets
.Ticket = strText
.Found = True
End With
Else
With vSets
.Ticket = ""
.Found = False
End With
End If
lbl_Exit:
TicketItem = vSets
Exit Function
End Function