Split contents of cell into single names then search for names on different sheet.

Good Morning All,

I'm trying to write a macro to split the contents of a cell when the contents are separated by a semicolon ;

This is for an automatic e-mail macro, the cell I'm trying to split contains the names of people previously e-mailed, like so. Bob Johnson; Michael Faraday

I'd like to split the names up and then search each name on another sheet and return their e-mail address.

I found the below, which splits the contents of cells into more cells.

http://www.excelforum.com/excel-prog...-at-every.html

Any help or advice would be greatly appreciated.

R

I've uploaded a stripped down version of my workbook with and example put into it. The workbook needs to be within that folder for all the macros to work correctly.

If you have a look at the programming you'll see that there are a couple of e-mail macros. The auto mail sub works great, and does everything I want to be able to do when I only have one contact to deal with. But if I have more than one contact then I'm unsure who I'd go about it. If you add a second contact to the contacts list, and select data on the transmittal sheet tab. choose both contacts and the example document then click print to pdf. it will log the data in the next tab - transmittal register. its using this information that I send automatic reminder e-mails. I want to be able to split the distribution coloumn into the names and then search those names on the contacts sheet to return the address for each person mailed to.

I'm sorry it's all very difficult to explain because I've added so many different functions to this workbook and they all tie in with each other. If you have any other questions I'd be more than happy to help and I'm very greatful for your response.

R

Xlbiznes, Thanks for your help.

I'm a bit confused by your code, where should I put it and how does it work?

Okay, I've looked over arrays a bit more and I understand what you're going for. Maybe if I give you a bit more details you can help me shape the above into a working function?

The distribution list is stored on sheet 'Transmittal Register' in column F. It will read something like this "Adam Woods; Paul Findlay; John Tyler"

The contact details for these people is found on sheet 'Contacts', Their full names e.g 'Adam Woods' is found in column K and their e-mail address is found in column C

As you can see in the below sub to create an automatic e-mail the 'To:' field in the e-mail is just the contents of Column F, but I'd like to make it split the names up and collect their e-mail addresses from contacts then use thi for the 'To:' field instead

Sub SendEMail()
    Dim Email As String, SubJ As String
    Dim Msg As String, URL As String
    Dim DocT As String
    Dim LastRow As Long, NextRow As Long, RowNo As Long
    Dim wsEmail As Worksheet
    Dim Attach As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim bng As Range
    Dim FPath As String
    Dim Ease As String
    Dim FName As String

    Set wsEmail = ThisWorkbook.Sheets("Transmittal Register")
    
    With wsEmail
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For RowNo = 2 To LastRow
            'Change "Date + 1" to suit your timescale
            
            If .Cells(RowNo, "L") = "" And .Cells(RowNo, "I") <= Date + 1 Then
                
                On Error Resume Next
                Set OutApp = GetObject("Outlook.Application")
                    On Error GoTo 0
                    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
                    Do: Loop Until Not OutApp Is Nothing
                Set OutMail = OutApp.CreateItem(0)
                Set bng = wsEmail.Cells(RowNo, "A")
                FPath = Application.ActiveWorkbook.Path
                FName = bng.Hyperlinks(1).Address
                Ease = FPath & "\" & FName
                With OutMail
                    Email = wsEmail.Cells(RowNo, "F")
                    DocT = wsEmail.Cells(RowNo, "D")
                    SubJ = "Automated E-mail - Document Due " & wsEmail.Cells(RowNo, "I")
                    Msg = ""
                    
                    Msg = "Good Day" & "," & vbCrLf & vbCrLf _
                        & "This is an automated e-mail to let you know that document" & vbCrLf _
                        & wsEmail.Cells(RowNo, "C") & " - " & DocT & vbCrLf _
                        & "That was issued for " & wsEmail.Cells(RowNo, "G") & " is due on " & wsEmail.Cells(RowNo, "I") & "." & vbCrLf & vbCrLf _
                        & "Many Thanks, " & vbCrLf & vbCrLf & "AutoMech"
                        
                    .To = Email
                    .CC = ""
                    .SentOnBehalfOfName = "PPU Document Control"
                    .Subject = SubJ
                    .ReadReceiptRequested = False
                    .Body = Msg
                    .Attachments.Add (Ease)
                    .Display

                End With
            Set OutApp = Nothing
            Set OutMail = Nothing
            Set bng = Nothing
            .Cells(RowNo, "L") = "RS"
            .Cells(RowNo, "Q") = Date
        End If
        
        If .Cells(RowNo, "L") = "RS" And .Cells(RowNo, "Q") <= Date - 3 And .Cells(RowNo, "Q") <> "" Then
        .Cells(RowNo, "Q") = Date
         On Error Resume Next
                Set OutApp = GetObject("Outlook.Application")
                    On Error GoTo 0
                    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
                    Do: Loop Until Not OutApp Is Nothing
                Set OutMail = OutApp.CreateItem(0)
                Set bng = wsEmail.Cells(RowNo, "A")
                FPath = Application.ActiveWorkbook.Path
                FName = bng.Hyperlinks(1).Address
                Ease = FPath & "\" & FName
                With OutMail
                    Email = wsEmail.Cells(RowNo, "F")
                    DocT = wsEmail.Cells(RowNo, "D")
                    SubJ = "Automated E-mail - Document Due " & wsEmail.Cells(RowNo, "I")
                    Msg = ""
                    
                    Msg = "Good Day" & "," & vbCrLf & vbCrLf _
                        & "This is an automated e-mail to let you know that document" & vbCrLf _
                        & wsEmail.Cells(RowNo, "C") & " - " & DocT & vbCrLf _
                        & "That was issued for " & wsEmail.Cells(RowNo, "G") & " is due on " & wsEmail.Cells(RowNo, "I") & "." & vbCrLf & vbCrLf _
                        & "Many Thanks, " & vbCrLf & vbCrLf & "AutoMech"
                        
                    .To = Email
                    .CC = ""
                    .SentOnBehalfOfName = "PPU Document Control"
                    .Subject = SubJ
                    .ReadReceiptRequested = False
                    .Body = Msg
                    .Attachments.Add (Ease)
                    .Display

                End With
            Set OutApp = Nothing
            Set OutMail = Nothing
            Set bng = Nothing
            .Cells(RowNo, "L") = "RS"
        End If
     Next
    End With
End Sub

Thanks again for persevering bud,

We're almost there! It works fine when I have only one contact, but when I have more than one. It does determine that I have more, but when it collects the e-mail address from the contacts, itjust gets the first e-mail address and repeats that 3 times. Then I get an error when trying to display the e-mail for some reason.

if I change it to this

email = email & Sheets("contacts").Range("c" & Application.WorksheetFunction.Match(a(x), Sheets("Contacts").Range("K:K"), -1)) & ","

it gets a little further and I get this '[email protected]; [email protected]; [email protected]' so it's skipped the second e-mail and returned the third example twice

Hey dude,

I gave that a try when I got the first error, but to no avail either. Though when I get the error it's that line that gets highlighted. If i hover over email its "[email protected]," and if I hover over a(x) it equals 'Example Two'. Which is the second name I put in to test it, so thats correct. So I'm unsure why it's not working from there on.

Hmmm, are you using -1 instead of 0? I gave it a look over but everything is in order.

It just occurred to me that I may have just put it into my sub wrong, so here's how I've input it

Sub SendEMail()
    Dim email As String, SubJ As String
    Dim Msg As String, URL As String
    Dim DocT As String
    Dim LastRow As Long, NextRow As Long, RowNo As Long
    Dim wsEmail As Worksheet
    Dim Attach As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim bng As Range
    Dim FPath As String
    Dim Ease As String
    Dim FName As String
    Dim a() As String

    Set wsEmail = ThisWorkbook.Sheets("Transmittal Register")
    
    With wsEmail
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For RowNo = 2 To LastRow
            'Change "Date + 1" to suit your timescale
            
            If .Cells(RowNo, "L") = "" And .Cells(RowNo, "I") <= Date + 1 Then
                
                On Error Resume Next
                Set OutApp = GetObject("Outlook.Application")
                    On Error GoTo 0
                    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
                    Do: Loop Until Not OutApp Is Nothing
                Set OutMail = OutApp.CreateItem(0)
                Set bng = wsEmail.Cells(RowNo, "A")
                FPath = Application.ActiveWorkbook.Path
                FName = bng.Hyperlinks(1).Address
                Ease = FPath & "\" & FName
                
                a = Split(wsEmail.Cells(RowNo, "F"), ";")
                For x = LBound(a) To UBound(a)
                    email = email & Sheets("contacts").Range("c" & Application.WorksheetFunction.Match(a(x), Sheets("Contacts").Range("K:K"), -1)) & "; "
                Next x
                email = Left(email, Len(email) - 1)
                MsgBox email
                
                With OutMail
                    DocT = wsEmail.Cells(RowNo, "D")
                    SubJ = "Automated E-mail - Document Due " & wsEmail.Cells(RowNo, "I")
                    Msg = ""
                    
                    Msg = "Good Day" & "," & vbCrLf & vbCrLf _
                        & "This is an automated e-mail to let you know that document" & vbCrLf _
                        & wsEmail.Cells(RowNo, "C") & " - " & DocT & vbCrLf _
                        & "That was issued for " & wsEmail.Cells(RowNo, "G") & " is due on " & wsEmail.Cells(RowNo, "I") & "." & vbCrLf & vbCrLf _
                        & "Many Thanks, " & vbCrLf & vbCrLf & "AutoMech"
                        
                    .To = email
                    .CC = ""
                    .SentOnBehalfOfName = "PPU Document Control"
                    .Subject = SubJ
                    .ReadReceiptRequested = False
                    .Body = Msg
                    .Attachments.Add (Ease)
                    .Display

                End With
            Set OutApp = Nothing
            Set OutMail = Nothing
            Set bng = Nothing
            .Cells(RowNo, "Q") = Date


            
        End If
        
        If .Cells(RowNo, "L") = "RS" And .Cells(RowNo, "Q") <= Date - 3 And .Cells(RowNo, "Q") <> "" Then
        .Cells(RowNo, "Q") = Date
         On Error Resume Next
                Set OutApp = GetObject("Outlook.Application")
                    On Error GoTo 0
                    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
                    Do: Loop Until Not OutApp Is Nothing
                Set OutMail = OutApp.CreateItem(0)
                Set bng = wsEmail.Cells(RowNo, "A")
                FPath = Application.ActiveWorkbook.Path
                FName = bng.Hyperlinks(1).Address
                Ease = FPath & "\" & FName
                With OutMail
                    email = wsEmail.Cells(RowNo, "F")
                    DocT = wsEmail.Cells(RowNo, "D")
                    SubJ = "Automated E-mail - Document Due " & wsEmail.Cells(RowNo, "I")
                    Msg = ""
                    
                    Msg = "Good Day" & "," & vbCrLf & vbCrLf _
                        & "This is an automated e-mail to let you know that document" & vbCrLf _
                        & wsEmail.Cells(RowNo, "C") & " - " & DocT & vbCrLf _
                        & "That was issued for " & wsEmail.Cells(RowNo, "G") & " is due on " & wsEmail.Cells(RowNo, "I") & "." & vbCrLf & vbCrLf _
                        & "Many Thanks, " & vbCrLf & vbCrLf & "AutoMech"
                        
                    .To = email
                    .CC = ""
                    .SentOnBehalfOfName = "PPU Document Control"
                    .Subject = SubJ
                    .ReadReceiptRequested = False
                    .Body = Msg
                    .Attachments.Add (Ease)
                    .Display

                End With
            Set OutApp = Nothing
            Set OutMail = Nothing
            Set bng = Nothing
            .Cells(RowNo, "L") = "RS"
        End If
     Next
    End With
End Sub

When I change it back to 0 I just get an error saying:
Run-time error '1004':
"Unable to get the Match Property of the WorksheetFunction class"

I'm so confused by this all. I can't see any little mistakes which is causing this error. It obviously works for the first loop because it picks up the first e-mail address and stores the second as a(x) but that's when the error occurs

:/ got it, after hours

it was in this line

 a = Split(wsEmail.Cells(RowNo, "F"), ";")

all I needed to do was add in a space

 a = Split(wsEmail.Cells(RowNo, "F"), "; ")