Maybe try this method
Sub SortEmailsByCategory() Dim objOutlook As Object Dim objInbox As Object Dim objEmail As Object Dim objFolder As Object Dim strCategory As String ' Create an Outlook Application object Set objOutlook = CreateObject("Outlook.Application") ' Get the Inbox folder Set objInbox = objOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' Loop through each email in the Inbox For Each objEmail In objInbox.Items ' Get the category of the email strCategory = objEmail.Categories ' Check if the email has a category If Len(strCategory) > 0 Then ' Create the target folder if it doesn't exist On Error Resume Next Set objFolder = objInbox.Folders(strCategory) On Error GoTo 0 If objFolder Is Nothing Then Set objFolder = objInbox.Folders.Add(strCategory) End If ' Move the email to the category folder objEmail.Move objFolder End If Next objEmail ' Clean up Set objEmail = Nothing Set objFolder = Nothing Set objInbox = Nothing Set objOutlook = Nothing End Sub




Reply With Quote