excelvbaoutlook

Moving Emails to Outlook Folders with VBA base in excel mapping


I am trying to move all the unread emails that have in the heather >3 "|" based on an Excel file path stored on my desktop to different folders, and if the folder doesn’t exist, create it and move it. The thing is, it works, but only with the first one. I assume there must be an error that stops it from working, but I am not able to solve it. Can someone shed some light on it?

Option Explicit

Public Sub ProcessUnreadEmails()
    Dim olNs As Outlook.Namespace
    Dim olInbox As Outlook.folder
    Dim olMail As Outlook.MailItem
    Dim Header As String
    Dim Words() As String
    Dim ThirdWord As String
    Dim DestFolder As String
    Dim ExcelApp As Object
    Dim Book As Object
    Dim Sheet As Object
    Dim Cell As Object
    Dim folder As Outlook.folder
    Dim Found As Boolean
    Dim Carpeta As Outlook.folder
    Dim Item As Object
    Dim UnreadItems As Outlook.Items
    Dim Filter As String
    
    'Get folder
    Set olNs = Application.GetNamespace("MAPI")
    Set olInbox = olNs.GetDefaultFolder(olFolderInbox)
    
    'Non read filter
    Filter = "[UnRead] = True"
    Set UnreadItems = olInbox.Items.Restrict(Filter)
    
    'Open excel
    Set ExcelApp = CreateObject("Excel.Application")
    Set Book = ExcelApp.Workbooks.Open(Environ$("USERPROFILE") & "\Desktop\WWOps SR Audit Status-Master.xlsx")
    Set Sheet = Book.Sheets(1)
    
    'Go throught emails
    For Each Item In UnreadItems
        'Check if are emails
        If TypeOf Item Is Outlook.MailItem Then
            Set olMail = Item
            'read subject
            Header = olMail.Subject
            
            'Extract audit_number from header and check if it has necessary format
            Words = Split(Header, "|")
            If UBound(Words) >= 3 Then
                ThirdWord = Trim(Words(2))
                
                'Check if column A contains audit_number stored in ThirdWord
                Found = False
                For Each Cell In Sheet.Range("B2:B8000")
                    If Cell.Value = ThirdWord Then
                        ' Verificar si tiene propietario
                        If Len(Sheet.Cells(Cell.row, 21).Value) = 0 Then
                            DestFolder = "Action Needed"
                        Else
                            DestFolder = Sheet.Cells(Cell.row, 21).Value
                        End If
                        Found = True
                        MsgBox (Found & " Row: " & Cell.row & " GPS Owner: " & DestFolder)
                        Exit For
                    End If
                Next Cell
                    
                'move to folder
                If Found Then
                    'check if folder exist or create it
                    On Error Resume Next
                    Set Carpeta = olInbox.Folders(DestFolder)
                    On Error GoTo 0
                    If Carpeta Is Nothing Then
                        Set Carpeta = olInbox.Folders.Add(DestFolder)
                        MsgBox "Carpeta '" & DestFolder & "' creada."
                    End If
                    olMail.Move Carpeta
                    MsgBox ("Moved to folder: " & Carpeta.Name)
                End If
            End If
        End If
    Next Item
    
    'close Excel
    Book.Close (False)
    ExcelApp.Quit

    'clean
    Set olMail = Nothing
    Set ExcelApp = Nothing
    Set Book = Nothing
    Set Sheet = Nothing
    Set olNs = Nothing
    Set olInbox = Nothing
    Set Carpeta = Nothing
End Sub

Thanks a lot.


Solution

  • Public Sub ProcessUnreadEmails()
        Dim olNs As Outlook.Namespace
        Dim olInbox As Outlook.folder
        Dim olMail As Outlook.MailItem
        Dim Header As String
        Dim Words() As String
        Dim ThirdWord As String
        Dim DestFolder As String
        Dim ExcelApp As Object
        Dim Book As Object
        Dim Sheet As Object
        Dim cell As Object
        Dim folder As Outlook.folder
        Dim Found As Boolean
        Dim ExcelOpened As Boolean
        Dim Carpeta As Outlook.folder
        Dim Item As Object
        Dim UnreadItems As Outlook.Items
        Dim Filter As String
        Dim i As Long
        Dim a As Long
        Dim count As Integer
        Dim pos As Long
        Dim findOwner As Boolean
        
        count = 0
        moved = False
        ExcelOpened = False
        findOwner = False
        'Get folder
        Set olNs = Application.GetNamespace("MAPI")
        Set olInbox = olNs.GetDefaultFolder(olFolderInbox)
    
        'Non-read filter (updated format without spaces)
        Filter = "[UnRead]=True"
        Set UnreadItems = olInbox.Items.Restrict(Filter)
        
        'Go through emails backward to avoid skipping due to collection modification
        For i = UnreadItems.count To 1 Step -1
            Set Item = UnreadItems.Item(i)
            
            'Check if is an email
            If TypeOf Item Is Outlook.MailItem Then
                Set olMail = Item
                
                ' Read subject
                Header = olMail.Subject
                
                'Check if header contains site_id and if yes extract
                If InStr(Header, "ST-") > 0 Then
                    ThirdWord = Mid(Header, InStr(Header, "ST-"), 10)
                    
                    'Open Excel only if it hasn't been opened yet
                    If Not ExcelOpened Then
                        Set ExcelApp = CreateObject("Excel.Application")
                        Set Book = ExcelApp.Workbooks.Open(Environ$("USERPROFILE") & "\Desktop\WWOps SR Audit Status-Master.xlsx")
                        Set Sheet = Book.Sheets(1)
                    End If
                    
                    'Check if column B contains audit_number stored in ThirdWord
                    Found = False
                    For Each cell In Sheet.Range("B2:B8000")
                        If cell.Value = ThirdWord Then
                            'LastColumn = Sheet.Cells(1, Sheet.Columns.count).End(xlToLeft).column
                            If Not findOwner Then
                                For a = 1 To 100
                                    If Sheet.Cells(1, a).Value = "GPS Owner" Then
                                        pos = a ' Store the column number in pos
                                        findOwner = True
                                        Exit For ' Exit loop once found
                                    End If
                                Next a
                            End If
                        
                            ' Check if there's an owner in column U
                            If Len(Sheet.Cells(cell.row, 21).Value) = 0 Then
                                DestFolder = "Action Needed"
                            Else
                                DestFolder = Sheet.Cells(cell.row, pos).Value
                            End If
                            Found = True
                            Exit For
                        End If
                    Next cell
    
                    ' Check if folder exists or create it
                    count = count + 1
                    Set Carpeta = Nothing
                    On Error Resume Next
                    Set Carpeta = olInbox.Folders(DestFolder)
                    On Error GoTo 0
                    ' Move to folder
                    If Found Then
                        If Carpeta Is Nothing Then
                            Set Carpeta = olInbox.Folders.Add(DestFolder)
                        End If
                        olMail.Move Carpeta
                    Else
                        Set Carpeta = olInbox.Folders("Action Needed")
                        olMail.Move Carpeta
                    End If
                End If
            End If
        Next i
        
        ' Close Excel if opened
        If Not ExcelApp Is Nothing Then
            MsgBox ("Entra")
            Book.Close (False)
            ExcelApp.Quit
            MsgBox ("Process finish. " & count & " Emails moved.")
        Else
            MsgBox ("No emails moved.")
        End If
        
        ' Clean up
        Set olMail = Nothing
        Set ExcelApp = Nothing
        Set Book = Nothing
        Set Sheet = Nothing
        Set olNs = Nothing
        Set olInbox = Nothing
        Set Carpeta = Nothing
    End Sub