title: Using VBA to Automate - Save multiple attachment based on multiple criteria to specific folders
body: <p>I send daily reports to multiple stakeholders (~10), based on the following criteria</p>
  <ul>
  <li>Criteria 1: Download attachments based on senders and 1 or 2 keywords from email sender and subject</li>
  <li>Criteria 2: Exclude weekends as reports are only sent to and responded from respective stakeholders on the weekdays.<br />
  Monday reports are downloaded from Friday's attachment</li>
  <li>Criteria 3: One company has 4 regions, the remaining are centralized.<br />
  Attachments from the company with 4 regions,are to be saved in a folder under the company title.<br />
  With the remaining companies, attachments are saved in their respective company folder name.<br />
  Files will be more descriptive with year, month and day as opposed to the parenting folder limited to Company name and <strong>year and month only</strong>.</li>
  </ul>
  <p>All the above has been attempted. I also need to create automation where each folder will hold files maxing 2 months only after which another folder would be created for attachments of those months.</p>
  <p>I appreciate my code is clunky and would need a faster version.</p>
  <pre class="lang-vb prettyprint-override"><code>Option Explicit
  
  Sub SaveOutlookAttachments()
  
      Dim objOutlook As New Outlook.Application
      Dim objNamespace As Outlook.Namespace
      Dim objFolder As Outlook.folder
      Dim objItem As Object
      Dim objMailItem As Outlook.MailItem
      Dim objAttachment As Outlook.Attachment
  
      'For Folders creation
  
      Dim fso As Scripting.FileSystemObject
      Dim dir As Scripting.Folders
      Dim dirFolderName As String
  
  
      'For Date settings
      Dim iBackdate As Integer
  
      ' Hardcoding Partners - 
      Dim COMP_A_North As String
      Dim COMP_A_South As String
      Dim COMP_A_East As String
      Dim COMP_A_West As String
      Dim COMP_B As String
      Dim COMP_C As String
      Dim COMP_D As String
      Dim COMP_E As String
      Dim COMP_F As String
  
  
      Set objNamespace = objOutlook.GetNamespace(&quot;MAPI&quot;)
      Set objFolder = objNamespace.Folders(1).Folders(&quot;Inbox&quot;)
  
  
      Set fso = New Scripting.FileSystemObject
  
  
      'Setting Partner Filters
   
      COMP_A_North = &quot;@SQL=&quot;&quot;urn:schemas:httpmail:fromname&quot;&quot; LIKE '%@compa%'&quot; &amp; &quot;AND 
      &quot;&quot;urn:schemas:httpmail:subject&quot;&quot; LIKE '%Scotland%'&quot;
      COMP_A_South = &quot;@SQL=&quot;&quot;urn:schemas:httpmail:fromname&quot;&quot; LIKE '%@compa%'&quot; &amp; &quot;AND 
      &quot;&quot;urn:schemas:httpmail:subject&quot;&quot; LIKE '%North%'&quot;
      COMP_A_East = &quot;@SQL=&quot;&quot;urn:schemas:httpmail:fromname&quot;&quot; LIKE '%@compa%'&quot; &amp; &quot;AND 
      &quot;&quot;urn:schemas:httpmail:subject&quot;&quot; LIKE '%Midlands%'&quot;
      COMP_A_West = &quot;@SQL=&quot;&quot;urn:schemas:httpmail:fromname&quot;&quot; LIKE '%@compa%'&quot; &amp; &quot;AND 
      &quot;&quot;urn:schemas:httpmail:subject&quot;&quot; LIKE '%London%'&quot;
      COMP_B = &quot;@SQL=&quot;&quot;urn:schemas:httpmail:fromname&quot;&quot; LIKE '%@compb%'&quot; &amp; &quot;AND 
      &quot;&quot;urn:schemas:httpmail:subject&quot;&quot; LIKE '%Missing%'&quot;
      COMP_C = &quot;@SQL=&quot;&quot;urn:schemas:httpmail:fromname&quot;&quot; LIKE '%@compc%'&quot; &amp; &quot;AND 
      &quot;&quot;urn:schemas:httpmail:subject&quot;&quot; LIKE '%Missing%'&quot;
      COMP_D = &quot;@SQL=&quot;&quot;urn:schemas:httpmail:fromname&quot;&quot; LIKE '%@compd%'&quot; &amp; &quot;AND 
      &quot;&quot;urn:schemas:httpmail:subject&quot;&quot; LIKE '%Missing%'&quot;
      COMP_E = &quot;@SQL=&quot;&quot;urn:schemas:httpmail:fromname&quot;&quot; LIKE '%compe%'&quot; &amp; &quot;AND 
      &quot;&quot;urn:schemas:httpmail:subject&quot;&quot; LIKE '%Missing%'&quot;
      COMP_F = &quot;@SQL=&quot;&quot;urn:schemas:httpmail:fromname&quot;&quot; LIKE '%@compf%'&quot; &amp; &quot;AND 
      &quot;&quot;urn:schemas:httpmail:subject&quot;&quot; LIKE '%Missing%'&quot;
  
   
          For Each objItem In objFolder.Items.Restrict(COMP_A_North)
  
          'Check Item Class
          If objItem.Class = Outlook.olMail Then
  
            'Set as Mail Item
             Set objMailItem = objItem
  
             With objMailItem
                Select Case Weekday(Now)
                    Case 7 ' Saturday: add extra day
                        iBackdate = 3
                    Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                      iBackdate = 4
                    Case Else ' Other days
                      iBackdate = 2
                   End Select
  
              ' Check date
              If .ReceivedTime &gt; DateAdd(&quot;d&quot;, -iBackdate, Now) Then
              
                      ' Save Attachments
                      
                  If objAttachment.Count &gt; 0 Then
                  
                  dirFolderName = &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; &quot;compa  Report UpTo&quot; &amp; 
                  Format(objAttachment.receivetime, &quot;yyyy-mm&quot;)
                  
                    If fso.FolderExists(dirFolderName) Then
                        Set dir = fso.GetFolder(dirFolderName)
                    Else
                        Set dir = fso.CreateFolder(dirFolderName)
                    End If
                  
                  
                  
                      For Each objAttachment In .Attachments
                          
          
                          
                          Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                          
  
                              objAttachment.SaveAsFile &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; 
          objAttachment.FileName = &quot;compa North and Iceland Region Report&quot; &amp; Format(.ReceivedTime, &quot;yyyy- 
           mm- dd&quot;)   'Put in a valid folder location to store attachements
  
  
                      Next
                  
                  End If
              
              End If
  
          End With
  
      End If
  
      Next
  
  
  
  
          For Each objItem In objFolder.Items.Restrict(COMP_A_South)
  
          'Check Item Class
          If objItem.Class = Outlook.olMail Then
  
              'Set as Mail Item
               Set objMailItem = objItem
  
              With objMailItem
                  Select Case Weekday(Now)
                      Case 7 ' Saturday: add extra day
                          iBackdate = 3
                      Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                          iBackdate = 4
                      Case Else ' Other days
                          iBackdate = 2
                  End Select
  
                  ' Check date
                  If .ReceivedTime &gt; DateAdd(&quot;d&quot;, -iBackdate, Now) Then
              
                      ' Save Attachments
                      If objAttachment.Count &gt; 0 Then
                  
                      dirFolderName = &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; &quot;compa  Report 
                      UpTo&quot; &amp; Format(objAttachment.receivetime, &quot;yyyy-mm&quot;)
                  
                      If fso.FolderExists(dirFolderName) Then
                          Set dir = fso.GetFolder(dirFolderName)
                      Else
                          Set dir = fso.CreateFolder(dirFolderName)
                      End If
                          
                          
                              For Each objAttachment In .Attachments
                              Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, 
                              objMailItem.Subject
                          
  
                              objAttachment.SaveAsFile &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; 
                              objAttachment.FileName = &quot;compa South Region  Report&quot; &amp; 
                              Format(.ReceivedTime, &quot;yyyy-mm-dd&quot;)   'Put in a valid folder location to 
                              store attachements
  
                          Next
  
                  End If
                  
              End If
  
          End With
  
      End If
  
      Next
  
  
      For Each objItem In objFolder.Items.Restrict(COMP_A_East)
  
          'Check Item Class
          If objItem.Class = Outlook.olMail Then
  
              'Set as Mail Item
              Set objMailItem = objItem
  
              With objMailItem
                  Select Case Weekday(Now)
                      Case 7 ' Saturday: add extra day
                          iBackdate = 3
                      Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                          iBackdate = 4
                      Case Else ' Other days
                          iBackdate = 2
                  End Select
  
                  ' Check date
                  If .ReceivedTime &gt; DateAdd(&quot;d&quot;, -iBackdate, Now) Then
              
                      ' Save Attachments
                      If objAttachment.Count &gt; 0 Then
                  
                      dirFolderName = &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; &quot;compa  Report 
                  UpTo&quot; &amp; Format(objAttachment.receivetime, &quot;yyyy-mm&quot;)
                  
                      If fso.FolderExists(dirFolderName) Then
                          Set dir = fso.GetFolder(dirFolderName)
                      Else
                          Set dir = fso.CreateFolder(dirFolderName)
                      End If
                          
                          
                          For Each objAttachment In .Attachments
                          Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                          
  
                              objAttachment.SaveAsFile &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; 
      objAttachment.FileName = &quot;compa East Region  Report&quot; &amp; Format(.ReceivedTime, &quot;yyyy-mm-dd&quot;)   'Put in 
      a valid folder location to store attachements
  
                          Next
                  End If
                  
              End If
  
          End With
  
      End If
  
      Next
  
  
  
  
      For Each objItem In objFolder.Items.Restrict(COMP_A_West)
  
          'Check Item Class
          If objItem.Class = Outlook.olMail Then
  
              'Set as Mail Item
              Set objMailItem = objItem
  
              With objMailItem
                  Select Case Weekday(Now)
                      Case 7 ' Saturday: add extra day
                          iBackdate = 3
                      Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                          iBackdate = 4
                      Case Else ' Other days
                          iBackdate = 2
                  End Select
  
                  ' Check date
                  If .ReceivedTime &gt; DateAdd(&quot;d&quot;, -iBackdate, Now) Then
              
                      ' Save Attachments
                      If objAttachment.Count &gt; 0 Then
                  
                      dirFolderName = &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; &quot;compa  Report 
      UpTo&quot; &amp; Format(objAttachment.receivetime, &quot;yyyy-mm&quot;)
                  
                  If fso.FolderExists(dirFolderName) Then
                      Set dir = fso.GetFolder(dirFolderName)
                  Else
                      Set dir = fso.CreateFolder(dirFolderName)
                  End If
                          
                          For Each objAttachment In .Attachments
                          Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                          
  
                              objAttachment.SaveAsFile &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; 
        objAttachment.FileName = &quot;compa West and Central Region  Report&quot; &amp; Format(.ReceivedTime, &quot;yyyy-mm- 
        dd&quot;)   'Put in a valid folder location to store attachements
  
                          Next
                          
                  End If
                  
              End If
  
          End With
  
      End If
  
      Next
  
  
  
  
      For Each objItem In objFolder.Items.Restrict(COMP_B)
  
          'Check Item Class
          If objItem.Class = Outlook.olMail Then
  
              'Set as Mail Item
              Set objMailItem = objItem
  
              With objMailItem
                  Select Case Weekday(Now)
                      Case 7 ' Saturday: add extra day
                          iBackdate = 3
                      Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                          iBackdate = 4
                      Case Else ' Other days
                          iBackdate = 2
                  End Select
  
                  ' Check date
                  If .ReceivedTime &gt; DateAdd(&quot;d&quot;, -iBackdate, Now) Then
              
                              ' Save Attachments
                      If objAttachment.Count &gt; 0 Then
                  
                      dirFolderName = &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; &quot;CompB Report 
      UpTo&quot; &amp; Format(objAttachment.receivetime, &quot;yyyy-mm&quot;)
                  
                      If fso.FolderExists(dirFolderName) Then
                          Set dir = fso.GetFolder(dirFolderName)
                      Else
                          Set dir = fso.CreateFolder(dirFolderName)
                      End If
                          
                          
                          For Each objAttachment In .Attachments
                          Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                          
  
                              objAttachment.SaveAsFile &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; 
      objAttachment.FileName = &quot;compb Report&quot; &amp; Format(.ReceivedTime, &quot;yyyy-mm-dd&quot;)   'Put in a valid 
      folder location to store attachements
  
                          Next
                  End If
              End If
  
          End With
  
      End If
  
      Next
  
  
  
  
      For Each objItem In objFolder.Items.Restrict(COMP_C)
  
          'Check Item Class
          If objItem.Class = Outlook.olMail Then
  
              'Set as Mail Item
              Set objMailItem = objItem
  
          With objMailItem
              Select Case Weekday(Now)
                  Case 7 ' Saturday: add extra day
                      iBackdate = 3
                  Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                      iBackdate = 4
                  Case Else ' Other days
                      iBackdate = 2
              End Select
  
              ' Check date
              If .ReceivedTime &gt; DateAdd(&quot;d&quot;, -iBackdate, Now) Then
              
                  ' Save Attachments
                  If objAttachment.Count &gt; 0 Then
                  
                  dirFolderName = &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; &quot;CompC  Report UpTo&quot; &amp; 
       Format(objAttachment.receivetime, &quot;yyyy-mm&quot;)
                  
                  If fso.FolderExists(dirFolderName) Then
                      Set dir = fso.GetFolder(dirFolderName)
                  Else
                      Set dir = fso.CreateFolder(dirFolderName)
                  End If
                          
                          For Each objAttachment In .Attachments
                          Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                          
  
                              objAttachment.SaveAsFile &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; 
      objAttachment.FileName = &quot;CompC Report&quot; &amp; Format(.ReceivedTime, &quot;yyyy-mm-dd&quot;)   'Put in a valid 
      folder location to store attachements
  
                          Next
                  End If
              End If
  
          End With
  
      End If
  
      Next
  
  
      For Each objItem In objFolder.Items.Restrict(COMP_D)
  
      'Check Item Class
      If objItem.Class = Outlook.olMail Then
  
          'Set as Mail Item
          Set objMailItem = objItem
  
          With objMailItem
              Select Case Weekday(Now)
                  Case 7 ' Saturday: add extra day
                      iBackdate = 3
                  Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                      iBackdate = 4
                  Case Else ' Other days
                      iBackdate = 2
              End Select
  
              ' Check date
              If .ReceivedTime &gt; DateAdd(&quot;d&quot;, -iBackdate, Now) Then
              
                  ' Save Attachments
                  If objAttachment.Count &gt; 0 Then
                  
                  dirFolderName = &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; &quot;CompD Report UpTo&quot; &amp; 
       Format(objAttachment.receivetime, &quot;yyyy-mm&quot;)
                  
                  If fso.FolderExists(dirFolderName) Then
                      Set dir = fso.GetFolder(dirFolderName)
                  Else
                      Set dir = fso.CreateFolder(dirFolderName)
                  End If
                          
                          For Each objAttachment In .Attachments
                          Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                          
  
                              objAttachment.SaveAsFile &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; 
       objAttachment.FileName = &quot;compd Report&quot; &amp; Format(.ReceivedTime, &quot;yyyy-mm-dd&quot;)   'Put in a valid 
       folder location to store attachements
  
                          Next
                  End If
                  
              End If
  
          End With
  
      End If
  
      Next
  
  
  
  
      For Each objItem In objFolder.Items.Restrict(COMP_E)
  
      'Check Item Class
      If objItem.Class = Outlook.olMail Then
  
          'Set as Mail Item
          Set objMailItem = objItem
  
          With objMailItem
              Select Case Weekday(Now)
                  Case 7 ' Saturday: add extra day
                      iBackdate = 3
                  Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                      iBackdate = 4
                  Case Else ' Other days
                      iBackdate = 2
              End Select
  
              ' Check date
              If .ReceivedTime &gt; DateAdd(&quot;d&quot;, -iBackdate, Now) Then
              
                  ' Save Attachments
                  If objAttachment.Count &gt; 0 Then
                  
                  dirFolderName = &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; &quot;CompE  Report UpTo&quot; &amp; 
      Format(objAttachment.receivetime, &quot;yyyy-mm&quot;)
                  
                  If fso.FolderExists(dirFolderName) Then
                      Set dir = fso.GetFolder(dirFolderName)
                  Else
                      Set dir = fso.CreateFolder(dirFolderName)
                  End If
                          
                          For Each objAttachment In .Attachments
                          Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                          
  
                              objAttachment.SaveAsFile &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; 
       objAttachment.FileName = &quot;compe  Report&quot; &amp; Format(.ReceivedTime, &quot;yyyy-mm-dd&quot;)   'Put in a valid 
       folder location to store attachements
  
                          Next
                  End If
                  
              End If
  
          End With
  
      End If
  
      Next
  
  
       For Each objItem In objFolder.Items.Restrict(COMP_F)
  
      'Check Item Class
      If objItem.Class = Outlook.olMail Then
  
          'Set as Mail Item
          Set objMailItem = objItem
  
          With objMailItem
              Select Case Weekday(Now)
                  Case 7 ' Saturday: add extra day
                      iBackdate = 3
                  Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                      iBackdate = 4
                  Case Else ' Other days
                      iBackdate = 2
              End Select
  
              ' Check date
              If .ReceivedTime &gt; DateAdd(&quot;d&quot;, -iBackdate, Now) Then
              
                  ' Save Attachments
                  If objAttachment.Count &gt; 0 Then
                  
                  dirFolderName = &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; &quot;CompF  Report UpTo&quot; &amp; 
       Format(objAttachment.receivetime, &quot;yyyy-mm&quot;)
                  
                  If fso.FolderExists(dirFolderName) Then
                      Set dir = fso.GetFolder(dirFolderName)
                  Else
                      Set dir = fso.CreateFolder(dirFolderName)
                  End If
                          
                          For Each objAttachment In .Attachments
                          Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                          
                              objAttachment.SaveAsFile &quot;C:\Users\rootname\OneDrive\Desktop\VBATesting&quot; &amp; 
      objAttachment.FileName = &quot;compf Report&quot; &amp; Format(.ReceivedTime, &quot;yyyy-mm-dd&quot;)   'Put in a valid 
       folder location to store attachements
  
                          Next
                  End If
                  
              End If
              
          End With
  
      End If
  
      Next
  
  End Sub
  </code></pre>