title: How to move mail from shared mailbox to a subfolder based on calculated entries in Excel sheet?
body: <p>I export e-mail details from an Outlook 2007 shared inbox folder into an Excel 2007 sheet (Sender, Subject, Date &amp; time received).</p>
  <p>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.</p>
  <ul>
  <li>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 &amp; time received, Yes/No).</li>
  <li>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 &quot;Yes&quot; (meaning it needs to be marked as read and moved to the folder &quot;No Response&quot; which is part of the same shared mailbox on the same level as the inbox) otherwise will show &quot;No&quot; (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.</li>
  </ul>
  <p>Exporting the e-mail details into an Excel sheet works and so do all of the formulas.</p>
  <p>I've not managed to get Outlook to take the appropriate action from the details in the Excel sheet.</p>
  <pre class="lang-vb prettyprint-override"><code>Sub ExportToExcel()
      
      ' Fully working, will export Sender, Subject &amp; Date Received from e-mails into spreadsheet *** Except For Non-Mail Items ***
      ' If getting &quot;spreadsheet user-defined type not defined&quot; go to Visual Basic &gt; Tools &gt; 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 = &quot;OE.xlsx&quot;
      strPath = &quot;C:\Users\JM\Desktop\&quot;
      strSheet = strPath &amp; strSheet
      Debug.Print strSheet
      
      'Select export folder
      Set nms = Application.GetNamespace(&quot;MAPI&quot;)
      Set fld = nms.PickFolder
          
      'Handle potential errors with Select Folder dialog box.
      If fld Is Nothing Then
          MsgBox &quot;There are no mail messages to export&quot;, vbOKOnly, &quot;Error&quot;
      Exit Sub
      
      ElseIf fld.DefaultItemType &lt;&gt; olMailItem Then
          MsgBox &quot;There are no mail messages to export&quot;, vbOKOnly, &quot;Error&quot;
      Exit Sub
      
      ElseIf fld.Items.Count = 0 Then
          MsgBox &quot;There are no mail messages to export&quot;, vbOKOnly, &quot;Error&quot;
      Exit Sub
      
      End If
      
      'Open and activate Excel workbook.
      Set appExcel = CreateObject(&quot;Excel.Application&quot;)
      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 &quot;Export Complete&quot;, vbOKOnly, &quot;Information&quot;
      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 &amp; &quot; doesn't exist&quot;, vbOKOnly, &quot;Error&quot;
      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 &quot;Export Completed&quot;, vbOKOnly
  End Sub
  </code></pre>
  <p>This is what the spreadsheet would look like, I can't show the original because of data protection.<br />
  <a href="https://i.stack.imgur.com/BxBeH.jpg" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/BxBeH.jpg" alt="enter image description here" /></a></p>
  <p>Most of the code has been put together from a few different websites.</p>
  <p>The predominant source of the code was this site
  <a href="http://www.vbaexpress.com/forum/showthread.php?52247-Macro-to-send-out-email-based-on-criteria-via-outlook/page3&amp;s=11b5bf88fb5e89d06f7c8b43f6f92d2e" rel="nofollow noreferrer">http://www.vbaexpress.com/forum/showthread.php?52247-Macro-to-send-out-email-based-on-criteria-via-outlook/page3&amp;s=11b5bf88fb5e89d06f7c8b43f6f92d2e</a></p>
  <p>I want the following code to:</p>
  <ul>
  <li>Mark the &quot;Yes&quot; e-mails as read and move them into the shared &quot;No Response&quot; folder in Outlook (in the same shared mailbox as the inbox the e-mail details were exported from).</li>
  </ul>
  <p>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.</p>
  <pre class="lang-vb prettyprint-override"><code>Option Explicit
  Const strWorkbook As String = &quot;C:\Users\jmurrey\Desktop\OE.xlsm&quot; 'The path of the workbook
  Const strSheet As String = &quot;Sheet1&quot; '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) = &quot;MailItem&quot; 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)) &gt; 0 Then
                      If InStr(1, .ReceivedTime, Arr(2, iRows)) &gt; 0 Then
                      'If the received time is in the message subject
                          If InStr(1, &quot;Yes&quot;, Arr(3, iRows)) &gt; 0 Then
                          'If The string above matches then mark the email as unread and move to 'No Response' folder
                              'MsgBox &quot;Match Found&quot;, vbOKOnly, &quot;Match&quot;
                              .FlagStatus = olFlagComplete
                              .UnRead = False
                              .Save
                              .Move Application.Session.Folders(&quot;No Response&quot;)
                              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 &amp; &quot;$]&quot;
      Set CN = CreateObject(&quot;ADODB.Connection&quot;)
      CN.Open ConnectionString:=&quot;Provider=Microsoft.ACE.OLEDB.12.0;&quot; &amp; _
        &quot;Data Source=&quot; &amp; strWorkbook &amp; &quot;;&quot; &amp; _
        &quot;Extended Properties=&quot;&quot;Excel 12.0 Xml;HDR=YES&quot;&quot;;&quot;
           
      Set RS = CreateObject(&quot;ADODB.Recordset&quot;)
      RS.Open &quot;SELECT * FROM [&quot; &amp; 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
  </code></pre>
  <p>How do I move e-mails to the folder &quot;No Response&quot; 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.</p>