共有Outlookフォルダから特定の数の電子メールを移動する

Question

私はVBAの新機能ですので、自分のコードと私がまだ学んでいるように私の知らない間違いを気にしないでください。手動で指定した数の電子メールを共有ネットワークメールボックスからチーム管理者のサブフォルダに移動すると、古いものから新しいものに移動し、マネージャと番号の両方を毎回変更することができます。私はコードを稼働させるのに大変なトラブルを抱えていましたが、私の解決策は手動で番号を選択してmoveコマンドを使用することでしたが、これは遅く、非常に面倒です。私は、フォルダ内の特定の件名を持つ少数の電子メールを特定のグループが働くサブフォルダに移動するためのスクリプトを作成しました。私はこれを私の現在の仕事に適応させようとしましたが、運がたくさんありません。どんな助けでも大歓迎です。 MailItem.Mpveは、そのコレクションからitemnを削除 -

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 i = Items.Count to 1 step -1を使用してください。

第2に、すべての項目をループしないでください。エントリids（rngarry）を既に知っている場合は、単にNamespace.GetItemfromIDと呼んでください。