title: Outlook - Save file from email with .xls attachment and from specific sender then move email to sub folder
body: <p>I want to trigger a macro when a new email from a specific email address with an .xls attachment is received in an inbox.
  I have tried to set a rule in outlook but it doesn't filter on the sender nor if it has an attachment.</p>
  
  <p>What I would like to do is the following:</p>
  
  <ol>
  <li>When a new email comes into the inbox check if it is from a certain email address ag:Myaddress.me.co.uk.  If the email is not from the correct address do nothing.</li>
  <li>If the subject line has certain words eg: " Price Checks".  It the subject doesn't match do nothing.</li>
  <li>If the email is from the correct address Check the new email has a .xls attachment.  If it doesn't have the .xls attachment do nothing.</li>
  <li>Save the attachment in a folder eg:"C:\MyFolder"</li>
  <li>Mark the Email as Read and move to a sub folder eg: "PriceCheckFolder"</li>
  </ol>
  
  <p>I have been using this code to check the inbox but it looks through all emails in the folder and I only want it to look at the first instance that fits the criteria.</p>
  
  <p>Many Thanks Melinda</p>
  
  <pre><code>‘in thisworkbook
  
  Private WithEvents Items As Outlook.Items
  
  Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim SubFolder As MAPIFolder
  
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    ' default local Inbox
    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
  End Sub
  
  
  Private Sub Items_ItemAdd(ByVal item As Object)
  
    On Error GoTo ErrorHandler
  
    Dim Msg As Outlook.MailItem
  
    If TypeName(item) = "MailItem" Then
      Set Msg = item
      Call SaveAttachmentsToFolder
    End If
  
  ProgramExit:
    Exit Sub
  
  ErrorHandler:
    MsgBox Err.Number &amp; " - " &amp; Err.Description
    Resume ProgramExit
  End Sub
  
  
  Sub SaveAttachmentsToFolder()
  
  'Error handling
    On Error GoTo SaveAttachmentsToFolder_err
  
  
  ‘in module1
  
  ' Declare variables
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As VbMsgBoxResult
    Dim StringLength As Long
    Dim Filename1 As String
    Dim FilenameA As String
    Dim FilenameB As String
  
  'Set the variable values to be used in the code
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("Test")
    i = 0
  
  ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
    ' "Nothing Found"
      Exit Sub
    End If
  
  ' Check each message for attachments
    For Each item In SubFolder.Items
      For Each Atmt In item.Attachments
        ' Check filename of each attachment and save if it has "xls" extension
        If Right(Atmt.FileName, 3) = "xls" Then
          StringLength = Len(Atmt.FileName)
  
          FileName = "\\feltfps0003\gengrpshare0011\Value Team\Melinda_BK\OutlookVBA\TestOutput\" &amp; Left(Atmt.FileName, (StringLength - 13)) &amp; Format(item.CreationTime, "ddmmmyyyy") &amp; ".xls"
          Atmt.SaveAsFile FileName
          i = i + 1
        End If
      Next Atmt
    Next item
  
  ' Clear memory
  SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set item = Nothing
    Set ns = Nothing
    Exit Sub
  
  ' Handle Errors
  SaveAttachmentsToFolder_err:
      MsgBox "An unexpected error has occurred." _
      &amp; vbCrLf &amp; "Please note and report the following information." _
      &amp; vbCrLf &amp; "Macro Name: GetAttachments" _
      &amp; vbCrLf &amp; "Error Number: " &amp; Err.Number _
      &amp; vbCrLf &amp; "Error Description: " &amp; Err.Description _
      , vbCritical, "Error!"sub
  Resume SaveAttachmentsToFolder_exit
  End Sub
  </code></pre>