从共享 Outlook 文件夹中移动特定数量的电子邮件

Question

每隔几天，我就会手动将指定数量的电子邮件从共享网络邮箱移动到团队经理的子文件夹中。 他们希望它们从最旧的移动到最新的。 经理和人数每次都可以更改。

我编写了一个脚本，用于将文件夹中具有特定主题行的少量电子邮件移动到特定组要工作的子文件夹中。

我已尝试将其调整到我当前的任务中。

Sub Moverdaily()

    On Error GoTo errHandler

    Dim olApp As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim msg As Outlook.MailItem
    Dim manager= As Outlook.MAPIFolder
    Dim cell,start,finish,rng   As Range
    Dim countE,countM  As Integer
    Dim emcount, casecount, movedcount
    Set rng = Range(Range("A2"), Range("A2").End(xlDown))
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set olFolder = objNS.Folders("Documents").Folders("Inbox")
    Set manager = objNS.Folders("Document").Folders("Inbox").Folders("Manager")
    Set finish = ThisWorkbook.Sheets("Mover").Range("I11")
    Set start = ThisWorkbook.Sheets("Mover").Range("I10")
    start.Value = Format(Now, "hh:mm:ss")
    Set emcount = Range("I12")
    Set casecount = Range("I13")
    Set movedcount = Range("I14")

    countM = 0
    countE = 0

    For i = olFolder.Items.count To 1 Step -1  
        For Each cell In rng
            If (cell.Text = (onlyDigits(msg.Subject))) Then
                msg.move manager 
                countM = 1 + countM
                cell.Offset(0, 1).Value = "Moved"
            End If
        Next
        countE = 1 + countE
    Next

    finish.Value = Format(Now, "hh:mm:ss")
    emcount.Value = countE
    casecount.Value = rng.count
    movedcount.Value = countM

errHandler:
    MsgBox ("Error " & Err.Number & ": " & Err.Description)
    Exit Sub

End Sub

Answer 1

首先，不要对您更改的集合使用“for each” - MailItem.Mpve从该集合中删除一个 itemn。 使用 a for i = Items.Count to 1 step -1代替。

其次，不要遍历所有项目 - 如果您已经知道条目 ID (rngarry)，只需调用Namespace.GetItemfromID 。