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.
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