Several persons initials in one cell, sent to their respective e-mail addresses.

I have been using the code below to send e-mails based on dates (props to paul) when the workbook is opened. What I can't figure out to do it to enter several initials into cell i,12 and have their respective e-mail addresses added to the "Strto" Value.

Example: J.D and D.J are held within an i,12 cell. I would like these to correspond to John.doe@gmail.com and doe.john@gmail.com.

Private Sub Workbook_Open()
Dim i As Long
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
    
    For i = 6 To Sheets("FMEA").Range("B65536").End(xlUp).Row
        If Sheets("FMEA").Cells(i, 13).Value = (Date) Then
            Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon
            Set OutMail = OutApp.CreateItem(0)
        
            strto = Sheets("FMEA").Cells(i, 12).Value
            'strcc = Sheets("FMEA").Cells(i, 13).Value & _
                        "; " & Sheets("FMEA").Cells(i, 5).Value
            strbcc = ""
            strsub = "Contract Expiry Notice"
            strbody = "Hi there" & vbNewLine & vbNewLine & _
                "Your contract, " & Sheets("FMEA").Cells(i, 11).Value & _
                ", is due to expire on " & Sheets("FMEA").Cells(i, 13).Value & _
                ". Please contact us at your earliest convenience." & _
                vbCrLf & vbCrLf & "Thank you."
    
            With OutMail
                .To = strto
                .CC = strcc
                .BCC = strbcc
                .Subject = strsub
                .Body = strbody
                .Send
            End With
    
            Set OutMail = Nothing
            Set OutApp = Nothing
        End If
    Next i
End Sub

Thanks a bunch,

Lacessit

Hi Walleye,

Thanks for helping It won't let me upload a copy of my sheet here at work but I can do it while at home. It seems the Named range I'm creating isn't working? Gives me a 'Type mismatch' error.

Managed to upload it using my phone

Hi Walleye,

I seem to be getting 'Runtime error '-2147221238 (8004010a)' automation error with this line of code?
I've tried creating a named range on a different sheet like you suggested but to no avail.

I have it working with one set of initials now, but when I seperate the initials with a "," and try to add another I get Runtime error '-2147221238 (8004010a)' automation error? I can get the error to not come up, but then the second set of initials in the cell still doesn't get an e-mail?

 With OutMail
                .To = strto

I'm still getting the same error when the initials are grouped as such DD,CJ. When I add a space it doesn't give me the error but doesn't send the e-mail. Any ideas? I ran the attached sheet unedited and still no luck .

AHA! I've made it work but putting the line of code you specified within the intAddress field like so

Private Sub Workbook_Open()
Dim i As Long
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Dim arrInits       As Variant
Dim intAddress   As Integer
    
    For i = 6 To Sheets("FMEA").Range("B65536").End(xlUp).Row
        If Sheets("FMEA").Cells(i, 13).Value = (Date) Then
            Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon
            'Set OutMail = OutApp.CreateItem(0)
           

            If InStr(1, Sheets("FMEA").Cells(i, 12).Value, ",") > 0 Then
                 arrInits = Split(Sheets("FMEA").Cells(i, 12).Value, ",")
            Else
                 ReDim arrInits(1 To 1)
                 arrInits = Sheets("FMEA").Cells(i, 12).Value
            End If

            For intAddress = LBound(arrInits) To UBound(arrInits)
                Set OutMail = OutApp.CreateItem(0)                 On Error Resume Next
                 strto = Application.WorksheetFunction.VLookup(arrInits(intAddress), _
                    ThisWorkbook.Names("NameMap5").RefersToRange, 2, False)
                 If Err <> 0 Then
                    strto = ""
                 End If
                 On Error GoTo 0

                 If strto > "" _
                 And strto <> "#N/A" Then
            'strto = Sheets("FMEA").Cells(i, 12).Value
            'strcc = Sheets("FMEA").Cells(i, 13).Value & _
                        "; " & Sheets("FMEA").Cells(i, 5).Value
            strbcc = ""
            strsub = "Contract Expiry Notice"
            strbody = "Hi there" & vbNewLine & vbNewLine & _
                "Your contract, " & Sheets("FMEA").Cells(i, 11).Value & _
                ", is due to expire on " & Sheets("FMEA").Cells(i, 13).Value & _
                ". Please contact us at your earliest convenience." & _
                vbCrLf & vbCrLf & "Thank you."
    
            With OutMail
                .To = strto
                .CC = strcc
                .BCC = strbcc
                .Subject = strsub
                .Body = strbody
                .Send
                
            End With
                  End If
    
            'Set OutMail = Nothing
            'Set OutApp = Nothing
            
            Next intAddress
            
        End If
    Next i
End Sub

Thanks Walleye you've been a great help. I think this may be solved

Hi Walleye,

I seem to be having a problem with what I believe is this piece of code.

For i = 6 To Sheets("FMEA").Range("B65536").End(xlUp).Row
        If Sheets("FMEA").Cells(i, 13).Value <= (Date) Then
            Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon

            If InStr(1, Sheets("FMEA").Cells(i, 12).Value, ",") > 0 Then
                 arrInits = Split(Sheets("FMEA").Cells(i, 12).Value, ",")
            'Else
                 'ReDim arrInits(1 To 1)
                 'arrInits = Sheets("FMEA").Cells(i, 12).Value
            End If

My problem is that the code works fine for the sample sheet I sent you but with other sheets it will miss initials and not send e-mails at the end (these sheets have more rows and more dates)

Example: judging by the initials it should be sending 11 e-mails but is only sending 9 - ending the sub after the 9th and ignoring the last 2.

sample sheet.xls

If you need anything let me know, tearing my hair out here >.<

Thanks a lot in advance

Seems to work fine, I'll test it live tomorrow morning.

Thanks again, you've been amazing

Lacessit

Edit: worked perfectly, thanks again for all your help! Now I'm just going to work in a counter with the initials and make a graph with it

Edit: Just in the process of adding an extra column to the namemap and introducting a counter which will track e-mails sent to each initial and having a bit of trouble fitting it in >.<