我可以加速这个VBA来移动电子邮件吗？

我有Outlook VBA，它完全符合我的要求。它将前一个工作日的电子邮件移动到一个新文件夹，并在辅助电子邮件收件箱中执行此操作

我正在寻找的是如何让它更快地移动电子邮件的建议

如果我手动将所有电子邮件复制到另一个文件夹，则需要几秒钟的时间。当我运行代码时，需要几分钟。这是我的密码：

Option Explicit

Sub Move_Yesterdays_Emails()

'***Creates a new folder named yesterdays date under the inbox***

 Dim myNameSpace As Outlook.NameSpace
 Dim strMailboxName As String
 Dim myFolder As Outlook.Folder
 Dim myNewFolder As Outlook.Folder
 Dim xDay As String
 Dim XDate As Date
 Dim thatDay As String
 strMailboxName = "Deductions Backup"


    If Weekday(Now()) = vbMonday Then
        XDate = Date - 3
    Else
        XDate = Date - 1
    End If

    thatDay = WeekdayName(Weekday(XDate))

 Set myNameSpace = Application.GetNamespace("MAPI")
 Set myFolder = Session.Folders(strMailboxName)
 Set myFolder = myFolder.Folders("Inbox")
 Set myNewFolder = myFolder.Folders.Add(XDate & " " & thatDay)

'***Finds all emails in the inbox from yesterday and moves them to the created folder***

    Dim Inbox As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Item As Object
    Dim Filter As String
    Dim i As Long

        Filter = "[ReceivedTime] >= '" & _
              CStr(XDate) & _
             " 12:00AM' AND [ReceivedTime] < '" & _
              CStr(XDate + 1) & " 12:00AM'"

        Debug.Print Filter

    Set myNameSpace = Application.GetNamespace("MAPI")
    Set myFolder = Session.Folders(strMailboxName)
    Set Inbox = myFolder.Folders("Inbox")
    Set Items = Inbox.Items.Restrict(Filter)
        Items.Sort "[ReceivedTime]"

    For i = Items.Count To 1 Step -1
        DoEvents
        If TypeOf Items(i) Is MailItem Then
            Debug.Print Items(i)
            Set Item = Items(i)
            Item.Move myNewFolder
        End If
    Next
End Sub

选项显式
子移动\u昨天\u电子邮件（）
'***在收件箱下创建一个名为yesterdays date的新文件夹***
将myNameSpace设置为Outlook.NameSpace
Dim strMailboxName作为字符串
将myFolder设置为Outlook.Folder
将myNewFolder设置为Outlook.Folder
Dim xDay作为字符串
Dim XDate作为日期
朦胧的那一天如弦
strMailboxName=“扣减备份”
如果工作日（Now（））=星期一，则
XDate=日期-3
其他的
XDate=日期-1
如果结束
thatDay=工作日名称（工作日（XDate））
设置myNameSpace=Application.GetNamespace（“MAPI”）
设置myFolder=Session.Folders（strMailboxName）
设置myFolder=myFolder.Folders（“收件箱”）
设置myNewFolder=myFolder.Folders.Add（XDate&“”&thatDay）
“***查找收件箱中昨天的所有电子邮件，并将其移动到创建的文件夹中***
将收件箱暗显为Outlook.Mapi文件夹
将项目设置为Outlook。项目
将项目变暗为对象
将筛选器设置为字符串
我想我会坚持多久
Filter=“[ReceivedTime]>=”&_
CStr（XDate）和_
“12:00AM”和[接收时间]<”&_
CStr（XDate+1）和“上午12:00”
打印过滤器
设置myNameSpace=Application.GetNamespace（“MAPI”）
设置myFolder=Session.Folders（strMailboxName）
设置收件箱=myFolder.Folders（“收件箱”）
设置项目=收件箱.Items.Restrict（过滤器）
Items.Sort“[ReceivedTime]”
对于i=项目。计数为1步骤-1
多芬特
如果项目类型（i）为MailItem，则
调试.打印项目（i）
集合项目=项目（i）
项目。移动myNewFolder
如果结束
下一个
端接头

---

你知道为什么这比手动移动项目慢得多吗，或者如何让它运行得更快吗？我不明白为什么要比手动操作花费更长的时间。

在查看和移动邮件之前，不要先过滤邮件，试着简单地查看邮件，然后决定是否移动它们

例如，这样一个简单的For循环可以实现以下目的：

For Each item In Inbox.Items
     If TypeOf item Is MailItem Then
         If item.ReceivedTime < Date And item.ReceivedTime > Date - 1 Then
             item.Move myNewFolder
         End If
     End If
 Next

收件箱中每个项目的

。项目
如果项目类型为MailItem，则
如果item.ReceivedTime<日期，item.ReceivedTime>日期-1，则
项目。移动myNewFolder
如果结束
如果结束
下一个

过滤某些东西的速度非常慢

---

但是请注意，我不能100%确定

Date-1

是否适用于午夜后不久收到的邮件。

您确定过滤确实是问题所在吗？我之所以这样做，是因为我对代码的理解是，过滤器在任何项目移动之前应用一次，而不是在每次移动之后重新应用。当我观看此运行时，项目立即开始移动。只是第一项到第二项再到第三项之间有一段时间。有时两次之间间隔2或3秒。所以我认为缓慢是在item.move过程中发生的，而不是在筛选过程中发生的……可能是，如果我手动选择所有项目并将它们放入子文件夹中，移动所有200+需要3秒钟，但代码需要5分钟才能全部完成。@t在这种情况下，我误解了您的代码落后的地方。我认为这是整个过程而不仅仅是运动部分。但请注意，无论如何，过滤总是很慢。如果你有什么想法，我会修改我的答案，你可以试试！谢谢你看，我放了一个调试计时器在里面，真的没有什么东西需要那么长时间。过滤时间为1秒。移动每件物品不到一秒钟，有时需要更多的时间。主要的问题是，有时移动物品时，它会感到饥饿，需要2或3秒。在移动了大约40封电子邮件之后，它似乎完全冻结了。即使没有挂断和冻结，如果每件物品持续1秒，考虑到我可以拖放200件物品，速度仍然很慢，可能不到2秒。令人沮丧的是，手动操作的速度要快得多。在Outlook中，有没有办法选择从某个日期显示的第一封电子邮件，然后选择它下面的所有电子邮件项目？比如换档+控制+降档功能？它在outlook中似乎不起作用，但可能是这样的，所以我只会做一步，而不是200多步。