Send reminder emails based on date in column, after finding last email correspondance

Hi

I am looking to set up a VBA to send follow up emails from excel. I have a few parameters outside of the norm for the macro to do what I would exactly like.

I would like the macro to run down Column P and send a mail each time it finds a cell containing either todays date (date macro is run) or a date in the past.
If cells in column P are blank or a date in the future no email would be sent. (Dates are normally displayed in written form e.g. 25 July 2019 - not sure if that makes a difference?

If a suitable date is found then an email would be sent to the email address in the same row which would be in column i.

Before an email is actually sent I would like the VBA to search all folders in outlook for the last email correspondence (sent or received) from that address and send it as a reply all and therefore keeping all previous content from earlier emails. (All VBA examples I can find are based on finding most recent subject line)

In terms of the email itself I would the other information to be found from the information found in the same row as the email it is being sent to-

• Cc email address - in column J - (often there will be no cc and this column blank)
• The subject of the email in column Q
• The greeting - Dear name - to be found in column R
• The body of the email to be found in column S
• Signature in column T
• Attachment location in column U - if none found send anyway

I can find similar code to most of my requests but putting it together or making the adjustments is beyond me.

Many thanks if anyone can help
Alan

I could do it all but the reply all concerns me. If you reply all, then you are looking for an email with address column I in the To, CC, or BCC fields. e.g. To: ALL EMPLOYEES. The email in Column I is there so: Dear Ken, I put one over on the boss. I called in sick leave yesterday but I got in my 18 holes of golf by 2 PM at Oak Tree. Paid to golf, I love this job!

One could be serious. e.g. To: ALL COMPANIES. Dear Ken, please send me another 100 pallets of Wiley Coyote bricks. The bricks sold by Road Runner company are too pricey!

If your goal is just a single To: field's email matching a single email in Column I, that might take some time but might be doable. I would have to research that. Folders and subfolders in Outlook are not the same as Win10's.

Hi Kenneth,

The goal is per your last paragraph - just a single To: field's email matching a single email in Column I.

My use of the phrase "reply all" was more about continuing the email thread.

Thanks
Alan

Change the value for email and ws. You might also want to change .Send to .Display to test.

Code:

---

Option Explicit

Dim oOFs() As outlook.Folder


Sub SendReminder()
  Dim email$, v, item, i, ws As Worksheet, r As Range, c As Range, cc As Range
  'Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim OL As outlook.Application, oMI As outlook.MailItem
 
  email = "ken@gmail.com"
  Set ws = Worksheets("SendReminder")
  Set r = ws.Range("I2", ws.Cells(ws.Rows.Count, "I").End(xlUp))
 
  Set OL = CreateObject("Outlook.Application")
  Erase oOFs()
  RecurseOFolders GetFolderPath(email, OL)
 
  For Each c In r
    Set oMI = Nothing
    Set cc = ws.Cells(c.Row, "P")
    If cc > Date Or cc = "" Then GoTo NextC
    For Each v In oOFs
      If v.Items.Count = 0 Then GoTo NextV
      For Each item In v.Items
        If TypeName(item) <> "MailItem" Then GoTo NextItem
        If item.SenderEmailAddress = c Then
          If oMI Is Nothing Then Set oMI = item
          If item.ReceivedTime > oMI.ReceivedTime Then Set oMI = item
        End If
NextItem:
      Next item
NextV:
    Next v
NextC:
    If Not oMI Is Nothing Then
      With oMI.Reply
        .Subject = ws.Cells(c.Row, "Q")
        .Body = ws.Cells(c.Row, "S") & vbCrLf & vbCrLf & ws.Cells(c.Row, "T") & .Body
          If ws.Cells(c.Row, "U") <> "" Then .Attachments.Add ws.Cells(c.Row, "U")
        .Send
      End With
    End If
  Next c
End Sub


Sub RecurseOFolders(CurrentFolder As outlook.MAPIFolder, _
  Optional skipTrash As Boolean = True)
  'Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim i As Long, oOSF As outlook.MAPIFolder, oOF As outlook.Folder
  Dim ii As Long
 
  For i = CurrentFolder.Folders.Count To 1 Step -1
    Set oOF = CurrentFolder.Folders(i)
    If IsArray(oOFs) Then
      ii = UBound(oOFs) + 1
      Else: ii = 0
    End If
    If skipTrash And oOF.Name = "Trash" Then
      ii = ii - 1
      Else
      ReDim Preserve oOFs(ii)
      Set oOFs(ii) = oOF
    End If
  Next i
 
  For Each oOSF In CurrentFolder.Folders
    If oOSF.Name <> "Deleted Items" Then RecurseOFolders oOSF
  Next oOSF
End Sub


'Similar to, http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#GetFolderPath
''Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Function GetFolderPath(ByVal FolderPath As String, oApp As outlook.Application) As outlook.Folder
    Dim oFolder As outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
   
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
  FoldersArray = Split(FolderPath, "\")
    'Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
  Set oFolder = oApp.Session.Folders.item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
  Set GetFolderPath = oFolder
    Exit Function
   
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

---

I am not sure what I am doing wrong but after starting the code it ran for a few minutes then an error message came up indicating that there was not enough memory to run it. I have never had an issue before so I wanted to check that I was doing everything correctly.
1. I updated your email to mine
2. On the test document I created I saved the worksheet as SendReminder to match the code
3. I went to Tools > References > Microsoft Outlook xx.0 Object Library > OK and ensured my version 16 was ticked

I am unsure what I am doing wrong?

When I debug after the error it highlights this row
If v.Items.Count = 0 Then GoTo NextV

Sounds like you set it up right. I would change the .Send to .Display to test. Try setting it up to just test one.

I tested it in 365 and Outlook v14. v14 took a while to finish just the one test.

I did not check the case where the To: column I's email might not exist. I will look at that today.

I have attached my simple test file. Change the column I to an existing email that was received. Delete the v14 Outlook library reference and add yours. Make the email change. As it runs, you should see in VBE Immediate window the number of outlook folders - 1 that it will search.

Once it works, it might be more efficient to get all MailItem's data from each Outlook folder found and put it into a scratch sheet. A sort could then be used for each column I to find the right MailItem to Reply to.

I did a similar thing to you with my previous effort and set up a v basic test doc - only had 2 emails.

I have just tried using your attachment (ensuring I made all the changes) but had identical error (there is not enough free memory to run this program....) I am using an i5 7th gen machine with only not much open.
although the debug had it happening here - For i = CurrentFolder.Folders.Count To 1 Step -1

I didn't see this - As it runs, you should see in VBE Immediate window the number of outlook folders - 1 that it will search.

Thanks
Alan

If no debug.print result, that tells me that there is an issue with the recurseofolders routine.

Change the email and run the test sub from a blank worksheet in my attachment's Module. It will put the folder names into column A.

Code:

---

Sub Test_RecurseOFolders() 
  Dim email$
  'Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim oMF As Outlook.MAPIFolder, OL As Outlook.Application
  Dim i, a
 
  email = "ken@gmail.com"
 
  Set OL = CreateObject("Outlook.Application")
  Erase oOFs()

  RecurseOFolders GetFolderPath(email, OL)
  ReDim a(1 To UBound(oOFs) + 1)
  For i = 1 To UBound(a)
    a(i) = oOFs(i - 1)
  Next i
  Range("A2").Resize(UBound(a)) = WorksheetFunction.Transpose(a) 
End Sub

---

Later today or tonight, I can post code to make sure that your parent folder is the email value's folder.

I am unable to run this code either. I get a Compile error: Sub or Function not defined against
Erase oOFs

?

Run it from the test file's Module. It has the supporting routines and that public variable.

Apologies - Yep that has now worked with all the folder names in Column A. Just over 4000 :-( 7 years of working in events for the same company!

The purpose of the macro is to follow up with people who haven't come back to me so maybe limiting the search to just the sent items may make the process quicker if having 4k of folder to search through each time is going to slow down the process?

If you can live with that, it will be much faster. You can try this for the RecurseOfolders line:

Code:

---

RecurseOFolders Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)

---

Or make it more simple and delete that line and for the first loop, use:

Code:

---

For Each v In Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)

---

You don't really need to recurse outlook folders since there would just be the Sent Items folder. It should work though. It is simple enough to not use RecurseOFolders(). I have not tested it so give it a shot.

It seems to vary if I can get my tests to work or not even though I am running the same code. (if it doesn't I get a memory error again)

I am unsure if I replaced the right - RecurseOfolders line: as there are a few in the code. Could you paste the entire code that I should use so i ensure I am doing it right.

It seemed to take 7 and half minutes to run one email. My first fail was when I tried to display 2.
Thanks

Is this on an Exchange Server?

During a Run in the VBE, press ESC key to abort macro after a bit. Look at the Immediate Window. The To names are shown but not the email address. If you use SenderEmailAddress on Exchange, that is not helpful.

IF you can live with the .To names, we can go from there.

This is all you need in a Module:

Code:

---

Sub SendReminder() 
  Dim v, item, i, ws As Worksheet, r As Range, c As Range, cc As Range
  'Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim OL As Outlook.Application, oMI As Outlook.MailItem, oFSentItems As Outlook.Folder
 
  Set ws = Worksheets("SendReminder")
  Set r = ws.Range("I2", ws.Cells(ws.Rows.Count, "I").End(xlUp))
 
  Set OL = CreateObject("Outlook.Application")
  Set oFSentItems = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
  If oFSentItems.Items.Count = 0 Then Exit Sub
 
  For Each c In r
    Set oMI = Nothing
    Set cc = ws.Cells(c.Row, "P")
    If cc > Date Or cc = "" Then GoTo NextC
    For Each item In oFSentItems.Items
      If TypeName(item) <> "MailItem" Then GoTo NextItem
  Debug.Print item.To, item.Sender, item.ReceivedTime, item.Reply.SenderEmailAddress
        If oMI Is Nothing Then Set oMI = item
        If item.ReceivedTime > oMI.ReceivedTime Then Set oMI = item
NextItem:
    Next item
NextC:
    If Not oMI Is Nothing Then
      With oMI.Reply
        .Subject = ws.Cells(c.Row, "Q")
        .Body = "Dear " & ws.Cells(c.Row, "R") & vbCrLf & vbCrLf & _
          ws.Cells(c.Row, "S") & vbCrLf & vbCrLf & ws.Cells(c.Row, "T") & .Body
          If ws.Cells(c.Row, "U") <> "" Then .Attachments.Add ws.Cells(c.Row, "U")
        .Display
      End With
    End If
  Next c
End Sub

---

Yes it is on an exchange server.

Again this code works but as soon as I enter 2 emails it ran for 30 mins or so and hadn't done anything for the second email. I think for this to be usable then it will need a new plan.
It seems to take so long to find the most recent mail when they would have been sent the last mail within the last week or 2 weeks?

Apologies - I have been away on holiday. Currently the code seems to only work on one email. As soon as two emails are added to my test document things begin to fail. Is there anything that can be done to get this useable.
Thanks