Trying to move emails in a loop, but not all get moved in the first run

问题

The VBA code does not move all emails with a certain words in the Subject "has been updated" and "Item" from the inbox to the subfolder "Neu". Emails should be already read. After 5-6 iterations , all emails will be moved. But why doesn't it work immediately after the first time of code running? Maybe you have faced the same problem? Out of 46 emails, 26 of them are moved firstly, then 39, then 44 and then 46.

Thank you very much in advance!

Sub Emails_Outlook_Transport()
    Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application

    Dim olNS As Outlook.Namespace
    Set olNS = olApp.GetNamespace("MAPI")

    Dim olFldr As Outlook.MAPIFolder
    Set olFldr = olNS.GetDefaultFolder(olFolderInbox)

    Dim Items As Outlook.Items
    Set Items = olFldr.Items

    Dim newFldr As Outlook.MAPIFolder
    Set newFldr = olFldr.Folders("Neu")

    Dim msg As Object
    Dim olMailItem As MailItem
    Dim Found As Boolean

    On Error Resume Next

    For Each msg In Items        
        If TypeOf msg Is MailItem And msg.UnRead = False Then
            Set olMailItem = msg

            If InStr(olMailItem.Subject, "has been updated") > 0 And InStr(olMailItem.Subject, "Item") > 0 Then
                olMailItem.Move newFldr
            End If 
        End If
    Next
End Sub

No error messages, just not a proper work of the code

回答1:

Problem:

Apparently when the items are moved around, it messes with the item being referred in the loop in case of For Each loop

Solution:

Work a Loop after counting the Items and Backwards.So that each item is referred by an Index.

Try this:

Sub Emails_Outlook_Transport()
    Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application

    Dim olNS As Outlook.NameSpace
    Set olNS = olApp.GetNamespace("MAPI")

    Dim olFldr As Outlook.MAPIFolder
    Set olFldr = olNS.GetDefaultFolder(olFolderInbox)

    Dim Items As Outlook.Items
    Set Items = olFldr.Items

    Dim newFldr As Outlook.MAPIFolder
    Set newFldr = olFldr.Folders("Neu")

    Dim msg As Object
    Dim olMailItem As MailItem
    Dim Found As Boolean

    Dim i As Integer

    For i = Items.Count To 1 Step -1
        If TypeOf Items(i) Is MailItem And Items(i).UnRead = False Then

            Set olMailItem = Items(i)

            If InStr(olMailItem.Subject, "has been updated") > 0 And InStr(olMailItem.Subject, "Item") > 0 Then
                olMailItem.Move newFldr
            End If
        End If
    Next
End Sub

来源：https://stackoverflow.com/questions/57391257/trying-to-move-emails-in-a-loop-but-not-all-get-moved-in-the-first-run

标签

excel

vba

outlook

outlook-vba