Retrieving mail attachments given criteria with VBA

Question

Scenario: I (together with great help from SO) finished this piece of code which downloads attachments from an e-mail account (outlook) with VBA.

Issue: Given the internal functioning of the code, and the sheer amount of e-mails to check (more than 800k) the code cannot function in available time. Last time I tried to run it, it went on for 8 days and then just stopped.

Question: Does anyone have any ideas on how to improve the efficiency of this code?

Obs: The code goes through a secondary e-mail account specified (first criteria), loops through the emails if they are from a certain sender (second criteria), opens file ad check if there are worksheets names "alpha" and "beta" (very smart idea given to me in SO, to find the third criteria), and if it does, saves the file in a final location.

Code:

Sub Get_Mail_Attachments()

Application.ScreenUpdating = False

Dim olApp As New Outlook.Application
Dim olNameSpace As Object
Dim olMailItem As Outlook.MailItem
Dim olFolder As Object
Dim olFolderName As String
Dim olAtt As Outlook.Attachments
Dim strName As String
Dim sPath As String
Dim i As Long
Dim j As Integer
Dim olSubject As String
Dim olSender As String
Dim sh As Worksheet
Dim LastRow As Integer

Dim TempFolder As String: TempFolder = VBA.Environ$("TEMP")
Dim wB As Excel.Workbook

'delete content except from row 1
ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.count).Delete

'set foldername and subject
olFolderName = ThisWorkbook.Worksheets("Control").Range("D10")
olSender = ThisWorkbook.Worksheets("Control").Range("D16")

sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Set olNameSpace = olApp.GetNamespace("MAPI")

'check if folder is subfolder or not and choose olFolder accordingly
Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")

If (olFolder = "") Then
    Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")
End If

'loop through mails
h = 2
For i = 1 To olFolder.Items.count

'check to see if it is an e-mail
If olFolder.Items(i).Class <> olMail Then
Else
Set olMailItem = olFolder.Items(i)

'check if the search name is in the email subject
    If (InStr(1, olMailItem.Sender, olSender, vbTextCompare) <> 0) Then

        With olMailItem

        For j = 1 To .Attachments.count

            strName = .Attachments.Item(j).DisplayName

'check if file already exists
            If Not Dir(sPathstr & "\" & strName) = vbNullString Then
                strName = "(1)" & strName
            Else
            End If

'Save in temp
            .Attachments(j).SaveAsFile TempFolder & "\" & strName
            ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName

'Open file as read only
            Set wB = Workbooks.Open(TempFolder & "\" & strName, True)
            DoEvents

'Start error handling
            On Error Resume Next
            Set sh = wB.Sheets("alpha")
            Set sh = wB.Sheets("beta")
            If Err.Number <> 0 Then

'Error = At least one sheet is not detected
            Else

'No error = both sheets found
                .Attachments(j).SaveAsFile sPathstr & "\" & strName
            End If
            Err.Clear
            Set sh = Nothing
            wB.Close
            On Error GoTo 0

            h = h + 1

        Next j

    End With

    End If

End If

Next i

Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"

End Sub

Answer 1

Some general review suggestions:

• Ditch the Hungarian Notation. Most people implement it incorrectly through no fault of their own.

• Add Option Explicit to the top of your code module. There are a couple of undefined variables in there.

• Use clear and meaningful variables names. What is h? After spending some time pondering the code, it appears to be the row number where you're writing information in your logging workbook, so call it something like logRowNum. That will make it pretty explicit to the next person (or you in 60 8 days.)

• You make reference to ThisWorkbook - it appears that you're expecting it to be your logging workbook, so Dim logWorkbook as Workbook and set it before opening any other workbooks. It appears that you don't have any issues with it for now but if you have an 8-day process running, someone could click on another workbook when it's open and ThisWorkbook now points at something else breaking your code.

• Indent your code neatly. Rubberduck (I'm a big fan and hang out in their chat room, but haven't yet started contributing) will help you with that. (It'll also help with renaming variables and a ton of other things.) Also, eliminating a lot of those extra blank lines will make it a bit more readable.

• Modify your If statements to test for what you're after instead of what you're not after. Having a blank True "statement" is very awkward to follow.

      'change:
          If olFolder.Items(i).Class <> olMail Then
          Else
            'some code here
          End If
      'to:
          If olFolder.Items(i).Class = olMail Then
            'some code here
          End If
  

• Eliminate empty Else clauses - they make me think you're going to write more code but haven't yet.

Specific to improving speed:

• Work with arrays instead of the spreadsheet itself.

• Turn off other screen updating things in Excel.

• Instead of downloading all attachments, make sure you're only downloading Excel workbooks, no need to download a PDF if you're not going to do anything with it:

      strName = .Attachments.Item(j).DisplayName
      If Instr(0, strName, "xls") > 0 then
        'rest of the code here
      End If
      'loops to next email message
  

• Short-cut your worksheet check, as well as ensuring they both exist:

      Dim AlphaFound as Boolean
      Dim BetaFound as Boolean
      On Error Resume Next
      Set sh = wB.Sheets("alpha")
      If Err.Number = 0 Then    'alpha exists
        AlphaFound = True
      End If
      If not AlphaFound Then
        'only look for "is alpha" if "alpha" isn't there
        Set sh = wB.Sheets("is alpha")
        If Err.Number = 0 Then    'alpha exists
          AlphaFound = True
        End If
      End If
      If AlphaFound Then
        Set sh = wB.Sheets("beta")
        If Err.Number = 0 Then  'beta exists
          BetaFound = True
        End If
      End If
      'turn off error ignoring as soon as possible vvv
      On error goto 0
      If AlphaFound and BetaFound then
        .Attachments(j).SaveAsFile sPathstr & "\" & strName
      End If
  

• Ditch the Set wb = nothing. You're doing it 800,000 times and each time you do, Excel has to free the memory then reallocate it when you hit the next Set wb = something statement. Leave the object in memory until you're done processing. Actually, VBA will Set all objects to Nothing automatically at the end of the Sub for you, so there's no reason to do it for any of them. (Note that wb is the only object you're manually freeing.)

• Put the trailing \ on all paths as early as possible to minimize concatenation later. (Don't know how much execution time it will save, but it will save typing time.)

      sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
      If Right(sPath, 1) <> "\" then
        sPath = sPath & "\"
      End If
  

• You have a DoEvents in there, which is being a good Windows citizen, but you may have it a bit too frequently. Maybe move it to outside your attachment count loop so you only do it once per email. I hate to suggest another counter in there, but maybe one that counts processed emails - every time you process 10 emails with attachments, DoEvents and reset the counter. That way other things can still run on the machine, but you're not pausing your process too frequently. If this is running on a dedicated machine (for 8 days!) maybe make it every 100 messages... If the machine is dedicated to this process, you might get away with not having it in there at all.