How to move mail from shared mailbox to a subfolder based on calculated entries in Excel sheet?

Question

I export e-mail details from an Outlook 2007 shared inbox folder into an Excel 2007 sheet (Sender, Subject, Date & time received).

I then use formulas in Excel 2007 to attempt to extract a reference from the subject. Then lookup the reference against some data exported from our computer system.

If the reference matches with a file reference then set criteria from a formula will populate an answer in column D (so that's Sender, Subject, Date & time received, Yes/No).
If the reference can't be found or the data from the file doesn't meet the criteria to merit a response column D will then show "Yes" (meaning it needs to be marked as read and moved to the folder "No Response" which is part of the same shared mailbox on the same level as the inbox) otherwise will show "No" (in which case nothing needs to be done to that e-mail). The Yes/No Column formula criteria will be a continuous work in progress.

Exporting the e-mail details into an Excel sheet works and so do all of the formulas.

I've not managed to get Outlook to take the appropriate action from the details in the Excel sheet.

Sub ExportToExcel()
    
    ' Fully working, will export Sender, Subject & Date Received from e-mails into spreadsheet *** Except For Non-Mail Items ***
    ' If getting "spreadsheet user-defined type not defined" go to Visual Basic > Tools > References and tick 'Microsoft Excel 12.0 Object Library'
    On Error GoTo ErrHandler
    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim strSheet As String
    Dim strPath As String
    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer
    Dim msg As Outlook.MailItem
    Dim nms As Outlook.NameSpace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object
    
    'Set path for spreadsheet
    strSheet = "OE.xlsx"
    strPath = "C:\Users\JM\Desktop\"
    strSheet = strPath & strSheet
    Debug.Print strSheet
    
    'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder
        
    'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
    
    ElseIf fld.DefaultItemType <> olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
    
    ElseIf fld.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
    
    End If
    
    'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Workbooks.Open (strSheet)
    Set wkb = appExcel.ActiveWorkbook
    Set wks = wkb.Sheets(1)
    wks.Activate
    appExcel.Application.Visible = True
       
    'Copy field items in mail folder.
    For Each itm In fld.Items
        intColumnCounter = 1
        Set msg = itm
        intRowCounter = intRowCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        intColumnCounter = intColumnCounter
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        'rng.Value = msg.SenderEmailAddress
        rng.Value = msg.SenderEmailAddress
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Subject
        intColumnCounter = intColumnCounter
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.ReceivedTime
    Next itm
                
    MsgBox "Export Complete", vbOKOnly, "Information"
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    Exit Sub
    
ErrHandler:
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
    Else
    End If
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    MsgBox "Export Completed", vbOKOnly
End Sub

This is what the spreadsheet would look like, I can't show the original because of data protection.

Most of the code has been put together from a few different websites.

The predominant source of the code was this site http://www.vbaexpress.com/forum/showthread.php?52247-Macro-to-send-out-email-based-on-criteria-via-outlook/page3&s=11b5bf88fb5e89d06f7c8b43f6f92d2e

I want the following code to:

Mark the "Yes" e-mails as read and move them into the shared "No Response" folder in Outlook (in the same shared mailbox as the inbox the e-mail details were exported from).

This is where I am so far. The code will recognise an e-mail, mark it as unread, flag it as complete but it won't move the items into the folder or process the whole folder.

Option Explicit
Const strWorkbook As String = "C:\Users\jmurrey\Desktop\OE.xlsm" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet
Sub ProcessFolder()
    Dim olItem As Object
    Dim olFolder As Folder
    Set olFolder = Session.PickFolder 'select the folder
    For Each olItem In olFolder.Items 'loop through the items
        If TypeName(olItem) = "MailItem" Then
            MoveToFolder olItem 'run the macro
        End If
        Exit For
    Next olItem
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

Sub MailFilter()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    MoveToFolder olMsg
lbl_Exit:
    Exit Sub
End Sub
     
Sub MoveToFolder(olMail As Outlook.MailItem)
    Dim olReply As Outlook.MailItem
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim oRng As Object
    Dim Arr() As Variant
    Dim iCols As Long
    Dim iRows As Long
    Dim strName As String
    'load the worksheet into an array
    Arr = xlFillArray(strWorkbook, strSheet)
    With olMail
        For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
            'If column 2 (starting at column 0) contains the e-mail address of the message
            If .SenderEmailAddress = Arr(0, iRows) Then
                'If the subject value is in the message subject
                If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
                    If InStr(1, .ReceivedTime, Arr(2, iRows)) > 0 Then
                    'If the received time is in the message subject
                        If InStr(1, "Yes", Arr(3, iRows)) > 0 Then
                        'If The string above matches then mark the email as unread and move to 'No Response' folder
                            'MsgBox "Match Found", vbOKOnly, "Match"
                            .FlagStatus = olFlagComplete
                            .UnRead = False
                            .Save
                            .Move Application.Session.Folders("No Response")
                            Exit For
                        End If
                    End If
                End If
            End If
        Next iRows
    End With
lbl_Exit:
    Set olReply = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub
     
Private Function xlFillArray(strWorkbook As String, _
    strWorksheetName As String) As Variant
    Dim RS As Object
    Dim CN As Object
    Dim iRows As Long
         
    strWorksheetName = strWorksheetName & "$]"
    Set CN = CreateObject("ADODB.Connection")
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
      "Data Source=" & strWorkbook & ";" & _
      "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
         
    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
         
    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
        Set RS = Nothing
        If CN.State = 1 Then CN.Close
        Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

How do I move e-mails to the folder "No Response" which is in the same shared mailbox as the inbox the data has been exported from and also run through all of the e-mails in the Excel sheet rather than just one.

Where are you at exactly? What are you stuck on? Do you get errors? Where? Please edit your question to include those answers! ;) Also (just bitching), why so much spacing and no indenting in your first code?? — R3uK
Sorted out the spacing, I use the spacing to help read through and understand how it's working, forgot to go back to it. Also updated the question itself — John Murrey
Is it really necessary to load the worksheet for every email? This seems very inefficient. The text of your reply suggests all you want to know is: (1) how to mark an email as read and (2) move it to another folder. (1) Search for " outlook mailitem unread". (2) Search for " outlook mailitem move". — Tony Dallimore
Might be worth recording the EntryID for each email - this is the unique email ID that a store (folder) assigns to an email when it is added to that store... note, moving the email to a different folder will change the EntryID. I'm pretty sure you can search for emails in VBA using it. msdn.microsoft.com/en-us/library/office/… — Darren Bartrup-Cook

Tony Dallimore Tony Dallimore · Accepted Answer · 2017-01-28T22:31:40

I have many issues with your code. With some issues, I am sure your code is faulty. With other issues I am not so sure. I will work down your code discussing my issues which I hope will help you address your problem.

Don’t use On Error GoTo ErrHandler during development or after release if you can avoid it. Your code will report the non-existence of the workbook but in the event of any other error it will just stop without giving no indication that it has failed to complete its task or the reason.

Try this for the workbook problem and add code for any other problems as they are discovered:

  Set wkb = Nothing
  On Error Resume Next
  Set wkb = appExcel.Workbooks.Open(strSheet)
  On Error GoTo 0
  If wkb Is Nothing Then
    Call MsgBox("I cannot open the workbook", vbOKOnly)
    Exit Sub
  End If

Dim intRowCounter As Integer. We were told to stop using data type Integer with VBA because it declares a 16-bit variable and such variables required special – slow - processing on 32 and 64-bit computers. When I got around to testing this claim, I was unable to detect any difference in processing speed. My reason for not using Integer for a row number is that its maximum value is 32767. I assume you will not have that many emails per folder but I will still suggest you get into the habit of declaring row numbers as Long.

You do not initialise intRowCounter. The default value is 0 and you add 1 before first use so it starts as 1.

strSheet = "OE.xlsx". Not very important but I hate anything that might cause confusion in the future. "OE.xlsx" is the name of a workbook and not the name of a worksheet. The term “spreadsheet” dates back to when there was only one sheet per file and I consider it obsolete.

You use PickFolder to select the folder which is fine if you want to be able run this macro against multiple folders. I was concerned you were using PickFolder because you did not know how else to get a folder reference particularly as you are using Explorer in MailFilter().

Alternatively, since you are playing with Explorer, perhaps this technique will appeal. The user selects the target folder and then starts your macro with this code at the beginning:

  Dim Exp As Outlook.Explorer
  Dim Fldr As Folder

  Set Exp = Outlook.Application.ActiveExplorer

  If Exp.Selection.Count = 0 Then
    Call MsgBox("No emails selected", vbOKOnly)
    Exit Sub
  Else
    Set Fldr = Exp.Selection(1).Parent
  End If

Exp.Selection(1) is the first or only selected email.

Exp.Selection(1).Parent is the folder containing the selected email.

There is no need to activate the worksheet.

I would never identify columns by number unless the nature of the task required it. I would replace your code by:

Const ColEmSenderEmailAddress As Long = 1
Const ColEmSubject As Long = 2
Const ColEmReceivedTime As Long = 3

wks.Cells(intRowCounter, ColEmSenderEmailAddress).Value = msg.SenderEmailAddress
wks.Cells(intRowCounter, ColEmSubject).Value = msg.Subject
wks.Cells(intRowCounter, ColEmReceivedTime).Value = msg.ReceivedTime

I think this is easier to read and, more importantly, if any of the columns move, you only need to update the constants.

In your first macro you use For Each itm In fld.Items to access the mail items. In the second you use Explorer to access the first or only selected email. You must be consistent.

I rarely use For Each itm In fld.Items and have never experimented with the sequence in which items are presented to the macro. In the second macro, you will be removed items from the folder by moving them elsewhere. Again I have never experimented so do not know how this might affect the items returned by For Each itm In fld.Items. I doubt there will be an effect but you will need to check if you want to use For Each itm In fld.Items in both macros.

I would use something like this for the first macro:

  Dim InxMi As Long
  Dim itm As MailItem

  For InxMi = 1 To Fldr.Items.Count
    Set itm = Fldr.Items(InxMi)
    Output macro to worksheet
  Next

Since you start at row 1 in the worksheet, this would mean the item number InxMi and the row number intRowCounter would be the same make matching rows and mail items in the second macro easier. If there is no change to the folder between creating the worksheet and running the second macro, there will be an exact match. If you allow additions and deletion between the two macros, it will be more complicated but rows and the mail items will be in the same sequence so not too complicated.

In the second macro, you need to start at the bottom row of the worksheet and read the folder up from the bottom:

  For InxMi = Fldr.Items.Count To 1 Step -1
    Set itm = Fldr.Items(InxMi)
    If appropriate Move item
  Next

Mail items within a folder are like rows within worksheets, if you delete one then all the one below move up. If you move up the worksheet and the folder, the row and mail items will continue to match because the moved mail items will below the current position.

You do not give enough detail for me to be more specific but I hope the above helps you progress.

How to move mail from shared mailbox to a subfolder based on calculated entries in Excel sheet?

3 Answers