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