Option Explicit Sub sbUsage() Dim iRow As Long Dim iRows As Long Dim iCol As Long Dim iItem As Long Dim iItems As Long Dim myInbox As Outlook.folder Dim mySubfolder As Outlook.folder Dim myItems As Outlook.Items Dim myItem As Outlook.MailItem Dim olkstore As Outlook.Store Dim olkRoot As Outlook.folder For Each olkstore In Outlook.Session.Stores If olkstore.DisplayName = "davidtallett29@gmail.com" Then Set olkRoot = olkstore.GetRootFolder End If Next Set myInbox = olkRoot.Folders.Item("Inbox") Set mySubfolder = myInbox.Folders("Newsletters") Set myItems = myInbox.Items If myItems.Count = 0 Then MsgBox "No items to process ..." Exit Sub End If iCol = 1 iRows = ActiveSheet.UsedRange.Rows.Count iItems = myItems.Count MsgBox "iItems " & iItems MsgBox "iRows " & iRows iItem = iItems ' start at the bottom of the Inbox Start_loop: If iItem = 0 Then GoTo Exit_Sub DoEvents Set myItem = myItems(iItem) MsgBox "myItem.SenderEmailAddress " & myItem.SenderEmailAddress For iRow = 1 To iRows DoEvents If myItem.SenderEmailAddress = Cells(iRow, iCol) Then DoEvents myItem.Move mySubfolder DoEvents MsgBox "moved ... " & myItem.SenderEmailAddress MsgBox "iItem " & iItem MsgBox "iRow " & iRow iItem = iItem - 1 GoTo Start_loop End If Next iRow iItem = iItem - 1 GoTo Start_loop Exit_Sub: MsgBox "Exit Sub..." End Sub |