Email multiple people based on response

I have an issue where I will make a meeting in Outlook for 80+ people and some people respond but don't send a reply so when I look in the tracking tab for the meeting I get a bunch of responses that say none because of this and it causes issues with accurate head count for meetings and catering for food.

I want to be able to email everyone in column C that has None as the response excluding the meeting organizer since they will always be none. I also need column A to edited over the course of this. Since I use outlook's GAL it shows each user as First Last for their name like John Doe for example. Everyone in the company has first.last@domain.com as the email so I'm hoping it's possible for someone to be able to turn First Last into that email and then email the list based off if they didn't respond. I attached a sample workbook, I hope this all makes sense

What you want to do is possible. It will however require VBA coding. Are you familiar with VBA?

1. In your workbook hit Alt + F11 to open the VBA editor.
2. Find your workbook's name in the VBAProject window on the left
3. Right click --> Insert --> Module
4. You can rename the module if you like
5. Double click on the newly created module
6. Paste the following code into it

Option Explicit

Sub EmailNoReplys()
     
Dim sSubject As String, sBody As String, sTo As String, sDomain As String
Dim r As Integer
Dim ThisWB As Workbook, ThisWS As Worksheet

Set ThisWB = ThisWorkbook
Set ThisWS = ThisWB.Worksheets("Sheet1") 'Change this
sSubject = "Subject" 'Change to suit
sBody = "Body" 'Change to suit
sDomain = "@domain.com" 'Change to suit
r = 2
With ThisWS
    Do Until Trim(Cells(r, 1).Value) = ""
        If .Cells(r, 3) = "None" Then 'if Response is 'None' will need to be exactly that...not 'none' or 'none ' or 'None ' etc...
            'Build the 'To' list
            If sTo = "" Then
                sTo = .Cells(r, 1).Value & sDomain & "; "
            Else
                sTo = sTo & .Cells(r, 1).Value & sDomain & "; "
            End If
        End If
    r = r + 1
    Loop
End With
EMail sTo, sSubject, sBody, False 'Change last argument to true if you want it to send right away

End Sub

Function EMail(StrTo As String, _
                              StrSubject As String, StrBody As String, Send As Boolean)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim signature As String
    
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
        If Err.Number <> 0 Then
            Err.Clear
            Set OutApp = CreateObject("Outlook.Application")
        End If
    Set OutMail = OutApp.CreateItem(0)

    Application.ScreenUpdating = False
    With OutMail
        .Display
    End With
        signature = OutMail.HTMLBody
    Application.ScreenUpdating = True
    
    On Error GoTo ExitFunc
    With OutMail
        .To = StrTo
        .cc = ""
        .BCC = ""
        .Subject = StrSubject
        .HTMLBody = StrBody & "<br>" & signature
        If Send = True Then
            .Send
        Else
            .Display
        End If
    End With

ExitFunc:
    Set OutMail = Nothing
    Set OutApp = Nothing
End Function

Edit the items in the code marked "Change" or "Change to suit"!

Now to add a button to your sheet to execute the code!
In Office 2010 or 2013 follow these steps to add the Developer Tab if you don't have it

1. Click on File
2. Click on Options
3. Click on Customize Ribbon
4. Check "Developer" in the list on the right
5. Click OK

Back in your sheet...

1. Click on the Developer Tab
2. Click on Insert
3. From the drop down select the top leftmost icon ... Button Form control
4. It will create a cross hairs for you to draw the button where you want it
5. After drawing the button a dialog will pop up for you to select the macro you want executed when the button is clicked
6. Select your new macro's module name

Two ways to correct this...
Add the "." in column A when you type the name so it's ready for the code, or use two columns one with the first name and one with the last name and modify the code accordingly.

Is there a space separating first name and last name?

Replace

            If sTo = "" Then
                sTo = .Cells(r, 1).Value & sDomain & "; "
            Else
                sTo = sTo & .Cells(r, 1).Value & sDomain & "; "
            End If

With

            If sTo = "" Then
                sTo = Replace(.Cells(r, 1).Value, " ", ".") & sDomain & "; "
            Else
                sTo = sTo & Replace(.Cells(r, 1).Value, " ", ".") & sDomain & "; "
            End If

Will only work for the email if there is one and only one space...

You are most welcome!!

I realize that this post is solved and am posting this code to demonstrate Outlook's ability to lookup the names and return the email addresses from the Contact folder.

Exchange server users often copy the GAL into their Outlook Contacts folder. This code provides a more flexible method of returning an individuals email address and other information as well.

This will send emails to those people in the list that meet the following criteria: Attendance =" Required" and Response = "None". The subject line and email message need to be modified for your email needs.

Sub SendEmailList()

    Dim Cell        As Range
    Dim Contacts    As Object
    Dim EmaiAddx    As String
    Dim EmailList   As String
    Dim FirstName   As String
    Dim LastName    As String
    Dim Message     As String
    Dim olApp       As Object
    Dim Rng         As Range
    Dim Subject     As String
        
      ' Fill these in with what you want in your email.
        Subject = "Test email"
        Message = "This sends the same email to multiple people."
        
        Set Rng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        
        Set olApp = CreateObject("Outlook.Application")
        
        Set Contacts = olApp.Session.GetDefaultFolder(10).Items
        
        For Each Cell In Rng
            If Cell <> "" And Cell.Offset(0, 1) Like "Required*" And Cell.Offset(0, 2) = "None" Then
                arr = Split(Cell, " ")
                FirstName = arr(LBound(arr))
                LastName = arr(UBound(arr))
            
                On Error Resume Next
                    EmailAddx = Contacts.Find("[FirstName] = '" & FirstName & "' and [LastName] = '" & LastName & "'").Email1Address
                    
                    If Err <> 91 And Err <> 0 Then
                        MsgBox "Run-time error '" & Err.Number & "':" _
                                & vbLf & vbLf & Err.Description, _
                                vbOKOnly + vbExclamation, "Outlook - Emails Not Sent"
                        Exit Sub
                    End If
                    
                    If Err = 0 Then EmailList = EmailList & EmailAddx & ";"
                On Error GoTo 0
            End If
        Next Cell
        
        If EmailList <> "" Then
            With olApp.CreateItem(0)
                .To = EmailList
                .Subject = Subject
                .Body = Message
                .Send
            End With
        End If
        
End Sub