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).
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).
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.
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
Original post is in attached Word document. Otherwise, you may not be able to understand my thread post completely :-/
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
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com
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
Good guess
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
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com