improve speed of outlook VBA copying from Excel attachment

Question

Over the past years we received thousands of emails with a specific type of attachment which we didn't use until now, but would now like to combine to one file. The outlook inbox has 38.000 unread emails by now. Each Email is sent from the same adress and contains two files, that are always named in a specific way "channelname-yyyy-mm-dd-tagesreport.csv" or "channelname-yyyy-mm-dd-tageskategorien.csv". I only need the "tageskategorien" file, the other one can be ignored. All of the excel files have the same structure - a header in line1 and data in line 2 seperated by ";" :

DATUM;PI;Visit;UC Tag;Usetime Tag;PI laufende Woche;Visit laufende Woche;PI laufender Monat;Visit laufender Monat

I already have a working code (see further down) but it is incredibly slow (9seconds per Email). It looks through the non-default Mailbox which receives all those emails, saves the attachment to a local folder, and copys the second line to another workbook based on some criteria. I know this is a lot to do for one macro, and there might not be a solution. Maybe VBA is simply not made for something like this (if this is the case please let me know).

As mentioned the code runs without errors, but even when I restrict the mail items to a time range of one month, it is very slow (9seconds per Email) and often gets stuck or behaves weirdly (doing some routines only part of the time,...).

I was wondering (as I only started using VBA recently) if there is any advice from the community on how to improve the speed of my code (or any other improvements to be done).

I will include the three parts of the code as a whole, as this question is about optimizing and I think it therefore doesn't make sense to only show a mini example.

The first part of the code accesses the emails one by one and calls two subroutines:

Option Explicit

Sub SearchEmails()

Dim oINS As NameSpace
Dim FolderInbox As MAPIFolder
Dim filtered_items As Items
Dim olMail As MailItem
Dim strFilter As String
Dim olRecip As Recipient

Set oINS = GetNamespace("MAPI")
Set FolderInbox = oINS.Folders("Onlinearchiv - [email protected]")
Set FolderInbox = FolderInbox.Folders("Posteingang")

strFilter = "[ReceivedTime]>'" & Format(Date - 10, "DDDDD HH:NN") & "'"

Set filtered_items = FolderInbox.Items.Restrict(strFilter)

If filtered_items.Count = 0 Then
    GoTo empty_objects
End If

For Each olMail In filtered_items
    Call SaveTagesreport.saveAttachtoDisk(olMail)
    Call mergeReport.Merge_oewaReport(olMail)
    
Next olMail


empty_objects:
    Set FolderInbox = Nothing
    Set oINS = Nothing

End Sub

The Call SaveTagesreport module simply saves one of the two attached files (depending on the Name) to a local folder. I was told that this step is needed as we can only copy a line if the file is saved somewhere. Originally I wanted to directly access it without saving it. This is how this part looks like:

Option Explicit
Function FileExists(FilePath As String) As Boolean
    Dim TestStr As String

    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment
Dim x As Long
Dim saveFolder As String
Dim Name As String


saveFolder = "Mypath/mylocalfolder"

For Each objAtt In itm.Attachments
x = InStr(1, "tageskategorien.csv", objAtt.DisplayName)
Name = objAtt.DisplayName
If InStr(1, objAtt.DisplayName, "tageskategorien.csv", 1) = 0 Then
    If Not FileExists(saveFolder & objAtt.DisplayName) Then
        objAtt.SaveAsFile saveFolder & objAtt.DisplayName
    End If
End If

Set objAtt = Nothing

Next

End Sub

The last part is about opening the .csv file, and writing the numbers into the AllData.xlsx file, if they are not already included. Then the .csv file is deleted again, because itonly contains this one line that I write to the AllData.xlsx file, so it is not needed afterwards.

Option Explicit

Sub Merge_oewaReport(itm As Outlook.MailItem)

'AllData.file Dims
Dim wb_path As String
Dim app_master As Excel.Application
Dim wb_master As Excel.Workbook
Dim ws_master As Excel.Worksheet

Dim ic_last As Integer
Dim ir_last As Integer
Dim ic_zeitr As Integer
Dim ic_date As Integer
Dim ic_ID As Integer

'EmailFile Dims
Dim objAtt As Outlook.Attachment
Dim FileName As String

Dim app_email As Excel.Application
Dim wb_email As Excel.Workbook
Dim ws_email As Excel.Worksheet

Dim ic_last2 As Integer
Dim ic_Date_e As Integer
Dim headerList() As String
Dim content() As String

'other dims
Dim Path As String
Dim datestr As Date
Dim datetemp As Date

Dim fID() As String
Dim fDay As String
Dim columnHeading As String
Dim i As Integer
Dim j As Integer
Dim Duplicate As Boolean


'Set up identifiers for AllData.file
Path = "mypath/mylocalfolder/"
wb_path = Path & "AllData.xlsx"
Set app_master = CreateObject("Excel.Application")
Set wb_master = app_master.Workbooks.Open(wb_path, ReadOnly:=False)
Set ws_master = wb_master.Sheets(1)

ic_last = ws_master.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
ir_last = ws_master.Cells(ws_master.Rows.Count, 1).End(-4162).Row
ic_date = ws_master.Cells.Find(What:="DATUM", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
ic_ID = ws_master.Cells.Find(What:="ID", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
ic_zeitr = ws_master.Cells.Find(What:="Zeitraum", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column


For Each objAtt In itm.Attachments

    FileName = objAtt.DisplayName
    If InStr(1, FileName, "tageskategorien.csv", 1) = 0 Then
        Set app_email = CreateObject("Excel.Application")
        Set wb_email = app_email.Workbooks.Open(Path & FileName, True, True)
        Set ws_email = wb_email.Sheets(1)
        
        'find Date and Name in Emailfile
        fID = Split(FileName, " - ")
        headerList = Split(ws_email.Cells(1, 1), ";")
        content = Split(ws_email.Cells(2, 1), ";")
        For i = 0 To UBound(headerList)
            If headerList(i) = "DATUM" Then
                datestr = content(i)
                Exit For
            End If
        Next i
        
        'check ID of every line that matches the date, to find if new Data already exists
        Duplicate = False
        For i = 2 To ir_last
            datetemp = ws_master.Cells(i, ic_date)
            If ws_master.Cells(i, ic_date).Value = datestr Then
                If ws_master.Cells(i, ic_ID) = fID(0) Then
                    Duplicate = True
                    Exit For
                End If
            End If
        
        Next i
        
        'If the new data is not a duplicate, then fill in a new line
        If Not Duplicate = True Then
            j = ws_master.Cells.Find(What:="ID", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
            ws_master.Cells(ir_last + 1, j) = fID(0)
            
            fID = Split(fID(1), "-")
            fDay = fID(UBound(fID))
            fDay = Split(fDay, ".")(0)
            If fDay = "tagesreport" Then
                ws_master.Cells(ir_last + 1, ic_zeitr) = "Tag"
            End If
           ir_last = ir_last + 1
            
            For i = 0 To UBound(headerList)
                columnHeading = headerList(i)
                
                Select Case columnHeading
                        
                    Case "DATUM"
                        ws_master.Cells(ir_last, ic_date) = datestr
                        
                        j = ws_master.Cells.Find(What:="Month", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = Month(datestr)
                        
                        j = ws_master.Cells.Find(What:="Year", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = Year(datestr)
                    
                    Case "PI"
                        j = ws_master.Cells.Find(What:="PI", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "Visit"
                        j = ws_master.Cells.Find(What:="Visit", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "UC Tag"
                        j = ws_master.Cells.Find(What:="UC Tag", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "Usetime Tag"
                        j = ws_master.Cells.Find(What:="Usetime Tag", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "PI laufende Woche"
                        j = ws_master.Cells.Find(What:="PI laufende Woche", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "Visit laufende Woche"
                        j = ws_master.Cells.Find(What:="Visit laufende Woche", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "PI laufender Monat"
                        j = ws_master.Cells.Find(What:="PI laufender Monat", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "Visit laufender Monat"
                        j = ws_master.Cells.Find(What:="Visit laufender Monat", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    End Select
            Next i
            
        End If
    End If
    Set objAtt = Nothing

Next

wb_master.Close SaveChanges:=True


'Delete the temp file again
For Each objAtt In itm.Attachments
    If FileExists(Path & objAtt.DisplayName) Then
        ' First remove readonly attribute, if set
      SetAttr Path & objAtt.DisplayName, vbNormal
      ' Then delete the file
      Kill Path & objAtt.DisplayName
    End If
Next

End Sub

I know this is a lot of code, but I am really stuck on where I could optimize this. I appreciate any sort of help.

Answer 1

There are several aspects that could improve the overall performance of your code. VBA is a valid way for implementing such tasks if you don't have any plans for deploying the solution on multiple machines. But if you need to distribute your solution I'd recommend creating a VSTO add-in instead, see Walkthrough: Create your first VSTO Add-in for Outlook for more information.

First, I'd suggest filtering items on the attachments presence, so you can introduce one more condition to the Restrict method. Here is a sample search string which checks the Subject line and attachments:

Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
                   Chr(34) & " Like '%training%' AND " & _
                   Chr(34) & "urn:schemas:httpmail:hasattachment" & _
                   Chr(34) & "=1"

Second, I'd recommend keeping the Excel application open while processing Outlook items. There is no need to open and close it each time.

Third, you can try to set up Excel's properties to increase performance such as ScreenUpdating and etc. Read more about them in the Maximizing Excel / VBA Automation Performance article.