Question

我对VBA很陌生，所以请放轻松我的代码和我对正确语法的无知，因为我还在学习，我工作的公司每隔几天就会手动从共享中移动指定数量的电子邮件网络邮箱到团队经理的子文件夹，他们希望它们从最旧到最新，并且每次管理员和号码都可以更改。我在使代码工作方面遇到了很多麻烦，到目前为止，我的解决方案是手动选择数字并使用移动命令，但这很慢且非常繁琐。我写了一个脚本，用于将文件夹中具有特定主题行的少量电子邮件移动到由特定组处理的子文件夹。我试图使这适应我目前的任务，但没有很多运气。任何帮助将不胜感激。

 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

首先，不要对每个＆＃34;使用＆＃34;使用您更改的集合 - <div class="testing-attributes">testing</div>从该集合中删除项目。请改用MailItem.Mpve。

其次，不要遍历所有项目 - 如果您已经知道条目ID（rngarry），只需致电for i = Items.Count to 1 step -1。

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

1 个答案: