Оптимизация кода - циклическая работа с подпапками Outlook для импорта электронных писем в Excel

Question

У меня есть макрос, который перебирает 2 подпапки Outlook и импортирует некоторую информацию электронной почты (отправитель, тема, дата) в лист Excel.В подпапках не так много писем (если вы будете искать в течение всего месяца, возможно, будет 100-200 писем).Тем не менее выполнение макроса занимает слишком много времени (~ 3 минуты).

Любой совет, как ускорить запуск макроса?

К вашему сведению - новинка для vba

Sub OptimizeCode_Begin()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
ActiveSheet.DisplayPageBreaks = False

End Sub

_____

Sub OptimizeCode_End()

ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

______

Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Long
Dim j As Long


Call OptimizeCode_Begin

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Individual Lot Inspections")
Set Folder2 = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Construction Site Inspections")

i = 1

For Each OutlookMail In Folder.Items
    If OutlookMail.ReceivedTime >= Range("From_date").Value Then
        Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
        Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
        ' Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body

        i = i + 1
    End If
Next OutlookMail

j = i + 1

For Each OutlookMail In Folder2.Items
    If OutlookMail.ReceivedTime >= Range("From_date").Value Then
        Range("eMail_subject").Offset(j, 0).Value = OutlookMail.Subject
        Range("eMail_date").Offset(j, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_sender").Offset(j, 0).Value = OutlookMail.SenderName

        j = j + 1
    End If
Next OutlookMail

Set Folder = Nothing
Set Folder2 = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

Call OptimizeCode_End

End Sub

Answer 1

Во-первых, никогда не просматривайте все элементы в папке.Используйте Items.Find/FindNext или Items.Restrict с запросом, подобным [ReceivedTime] > '2018-09-01'.

Во-вторых (если вы используете цикл), не выполняйте непрерывную оценку выражений внутри цикла, которые никогда не меняются.В вашем случае это Range("From_date").Value, Range("eMail_subject"), Range("eMail_date"), Range("eMail_sender").Оцените эти выражения перед началом цикла, сохраните возвращаемые значения в переменных и используйте их внутри цикла.