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

[Lacessit]

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