Sorting Emails To Folders

[hondamann]

Hi... Newbie here. I just wrote a whole thread, tried to submit it, and was rejected for something like URLs or indecent words (but I had neither, so I'm not sure what was going on). I'm going to post my question below (hopefully).

[hondamann]

Hi everyone. First-timer here. I'm new at writing macros in Outlook and could use some help. Here's what I'm trying to do:

(1) I want to sort e-mails (based on e-mail address) from various folders that I choose... into folders where they should go. The folder structure is very extensive -- 3 to 7 layers deep -- because I need it to be very organized.

(2) I have already made a successful macro for this that uses SELECT CASE, but there is 1 main issue: the macro size. I have hundreds of e-mail addresses -- and when I run the macro, it fails because it's too big. So, I have to whittle it down and remove some of the entries to make it work. That's a problem. I want to be able to run through however many thousands of addresses I eventually have.

(3) I figured an Excel worksheet may help solve the issue, so I created a workbook with just 1 worksheet (Sheet1). It contains 2 columns -- the e-mail addresses (in all-lowercase) and their respective destination folders... something like this:
---> THIS CONTENT WAS NOT ALLOWED TO BE POSTED APPARENTLY
Column E may be setup incorrectly for what I'm trying to accomplish.

(4) This is my new macro -- the one where I try to use the Excel file. So far, it has not worked due to the destination problem. I'm not married to it in any way, and am very open to adjusting it to whatever method works best for my need, so if you have a suggestion -- any suggestion -- I'd be happy to be enlightened by it.

[hondamann]

Macro summary:
- Opens my Excel workbook (where the email addresses and paths are stored)
- Opens a text document (to write the email address of every email being processed... this is how I know that something needs to be added to the Excel list)
- Tells Outlook to look through 2 predetermined/constant folders (or however many I eventually need it look through)
- Tells Outlook to find an e-mail message and locates the Sender Address, then forces it to lowercase so it can be matched
- Tells Outlook to look for a matching address in Column D of the Excel worksheet (the destination paths are Column E)
- Show a message box with pertinent information (this is just to troubleshoot)
- If it finds a matching address, then it will move it to the destination folder (this is the new part I just wrote that doesn't seen to be coded correctly.
- If there is folder contains no mail messages, then it moves on to the next folder
- Loops through all of the mail messages and search folders until the process is over, then displays a "macro complete" message box
*** Again, I'm not married to any of this, so if you have a better way to do it, I'm all ears and open to learning

Sub TestToSortEmailsBySenderAddress()
' // Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim Items As Outlook.Items
Dim FolderSelector As Integer
Dim lngCount As Long
Dim OriginallngCount As String
Dim LowerCaseAddress As String
Dim ExcelEmail As String
Dim ExcelPath As String
Dim MoveToPath As String
Dim MoveToFldrPath As Outlook.MAPIFolder
' //This is where a list of e-mail addresses will be written to
Const FILEPATH = "C:\Users\Bill\Desktop\OutlookMacroOutput.txt"

' // The following 20 or so lines opens the Excel workbook that contains e-mail addresses and folder paths
Dim xlApp As Object
Dim sourceWB
Dim sourceWS

Set xlApp = CreateObject("Excel.Application")

With xlApp
.Visible = True
.EnableEvents = True
End With

strFile = "C:\Users\Bill\Desktop\EmailsToSortToFolders.xlsx" 'Put your file path.

Set sourceWB = xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
Set sourceWS = sourceWB.Worksheets("Sheet1")
sourceWB.Activate



On Error GoTo MsgErr
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

Open FILEPATH For Output As 1

For FolderSelector = 1 To 2

If FolderSelector = 1 Then Set Items = Inbox.Folders("From Schools").Items
If FolderSelector = 2 Then Set Items = Inbox.Folders("From Staff").Items


OriginallngCount = Items.Count

If OriginallngCount = "" Then
GoTo MoveToNextFolder
End If

' // Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items(lngCount)

Item.UnRead = True

If Item.Class = olMail Then

Print #1, "Address: " and Item.SenderEmailAddress


LowerCaseAddress = LCase(Item.SenderEmailAddress)

For i = 1 To 5
ExcelEmail = "D" + CStr(i)
ExcelPath = "E" + CStr(i)
MoveToPath = sourceWS.Range(ExcelPath)
Set MoveToFolderPath = Inbox.MoveToPath

MsgBox "This item is currently being processed:" _
and vbCrLf and "LowerCaseAddress: " and LowerCaseAddress _
and vbCrLf and "Excel Email Cell: " and ExcelEmail _
and vbCrLf and "Excel Path Cell: " and ExcelPath _
and vbCrLf and "Excel Email: " and sourceWS.Range(ExcelEmail) _
and vbCrLf and "MoveTo Path Cell: " and MoveToPath _
and vbCrLf and "MoveTo Folder: " and MoveToFolderPath _
, vbInformation, "Information Box"

MoveToPath = MoveToFolderPath

If LowerCaseAddress = sourceWS.Range(ExcelEmail) Then
Item.Move MoveToFolderPath
GoTo GoToNextEmail
End If

Next i


End If
GoToNextEmail:
Next lngCount

'// Move to Next Folder
MoveToNextFolder:
Set Items = Inbox.Items
Next FolderSelector

Close #1

sourceWB.Deactivate

MsgBox "***** MACRO COMPLETE *****" _
, vbInformation, "Information Box"



MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing

Exit Sub

'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
and vbCrLf and "Error Number: " and Err.Number _
and vbCrLf and "Error Description: " and Err.Description _
and vbCrLf and "Email Address: " and Item.SenderEmailAddress _
and vbCrLf and "MoveTo Folder: " and MoveToPath _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub

[hondamann]

Original post is in attached Word document. Otherwise, you may not be able to understand my thread post completely :-/

[gmayor]

Do we take it that you want to look through all the folders under Inbox for items in your worksheet and if found move the item to the folder indicated? This could result in some items being processed several times and others not being processed because they are not in your worksheet.

It would make more sense to move the messages automatically as they arrive; or to start with them all in the Inbox so you would know which have not been moved.

However the following will look through all the subfolders of Inbox (and their sub folders) and compare then with the folder indicated in your spreadsheet. There is a proviso and that is that you need to change your worksheet to show only the final folder name and that must be unique in your Outlook folder tree or setting the folder is going to be an issue. e.g.

edutest@test.edu Education
bustest@test.biz Businesses
etc

The code will take a while if it has a lot of messages to process. Messages already in the correct folder are not processed.


Option Explicit

Sub MoveMessagesFromWorksheet()
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Folder
Dim olNS As Outlook.NameSpace
Dim xlApp As Object
Dim xlWB As Object
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
xlApp.Visible = True
Set xlWB = xlApp.workbooks.Open("C:\Users\Bill\Desktop\EmailsToSortToFolders.xlsx")
Set cFolders = New Collection
Set olNS = GetNamespace("MAPI")
cFolders.Add olNS.GetDefaultFolder(olFolderInbox)
Do While cFolders.Count > 0
Set olFolder = cFolders(1)
cFolders.Remove 1
ProcessFolder olNS, olFolder, xlWB
For Each SubFolder In olFolder.folders
cFolders.Add SubFolder
Next SubFolder
Loop
MsgBox "Finished"
lbl_Exit:
Set olFolder = Nothing
Set SubFolder = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub

Sub ProcessFolder(olNS As Outlook.NameSpace, _
iFolder As Outlook.Folder, _
xlWB As Object)
Dim i As Long, j As Long
Dim olItem As Object
Dim strTarget As String
Dim olTarget As Outlook.Folder
Dim strAddress As String
Dim lngLastRow As Long
lngLastRow = xlWB.Sheets(1).Range("D" & xlWB.Sheets(1).Rows.Count).End(-4162).Row
For i = iFolder.Items.Count To 1 Step -1
Set olItem = iFolder.Items(i)
If olItem.Class = olMail Then
strAddress = LCase(olItem.SenderEmailAddress)
With xlWB.Sheets(1)
For j = 2 To lngLastRow
If Trim(.Range("D" & j).Value) = strAddress Then
Set olTarget = GetTargetFolder(olNS, .Range("E" & j))
If Not iFolder = olTarget Then olItem.Move olTarget
Exit For
End If
DoEvents
Next j
End With
DoEvents
End If
Next i
lbl_Exit:
Set olItem = Nothing
Set olTarget = Nothing
Exit Sub
End Sub

Function GetTargetFolder(olNS As Outlook.NameSpace, _
strFolder As String) As Outlook.Folder
Dim colFolders As New Collection
Dim olTarget As Folder
Dim olTargetSub As Folder
colFolders.Add olNS.GetDefaultFolder(olFolderInbox)
Do While colFolders.Count > 0
Set olTarget = colFolders(1)
colFolders.Remove 1
If olTarget.Name = strFolder Then
Set GetTargetFolder = olTarget
Debug.Print GetTargetFolder.FolderPath
GoTo lbl_Exit
End If
For Each olTargetSub In olTarget.folders
colFolders.Add olTargetSub
Next olTargetSub
Loop
lbl_Exit:
Set colFolders = Nothing
Set olTarget = Nothing
Set olTargetSub = Nothing
Exit Function
End Function

[hondamann]

Your macro is significantly more compact! That's awesome. How would one tweak it to just process one particular folder?

I'm guessing it has to do with:

cFolders.Add olNS.GetDefaultFolder(olFolderInbox)

Do While cFolders.Count > 0
Set olFolder = cFolders(1)
cFolders.Remove 1
ProcessFolder olNS, olFolder, xlWB
For Each SubFolder In olFolder.Folders
cFolders.Add SubFolder
Next SubFolder
Loop

[gmayor]

Good guess :yes

Change the following section. As you didn't say which folder - this will let you pick one.


'Set cFolders = New Collection
Set olNS = GetNamespace("MAPI")
Set olFolder = olNS.PickFolder 'add this line
' cFolders.Add olNS.GetDefaultFolder(olFolderInbox)
' Do While cFolders.Count > 0
' Set olFolder = cFolders(1)
' cFolders.Remove 1
ProcessFolder olns, olFolder, xlWB 'keep this line
' For Each SubFolder In olFolder.folders
' cFolders.Add SubFolder
' Next SubFolder
' Loop