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
If olFolder.Items(i).Class <> olMail Then : Else
toIf olFolder.Items(i).Class = olMail Then
and get rid of theElse
. I don't think it'll make you code much faster, but it will make it more readable. For readability, test for the condition you want, not the one you don't want. \$\endgroup\$ – FreeMan Jun 2 '17 at 11:08If Err.Number <> 0 Then
. Though I'd assume you want to create the "alpha" and "beta" worksheets if they don't exist and that code is missing? \$\endgroup\$ – FreeMan Jun 2 '17 at 11:13If Err.Number = 0 Then
, though, the way you've got it written, it's only testing for the existence of "beta". It will look for that whether "alpha" exists or not, which may not be what you're after. \$\endgroup\$ – FreeMan Jun 2 '17 at 11:33