Email multiple users based on result of applied filter

[Ana Sheila Martins]

Good morning,

I need a little help with a project I am working on. What I have is an incident alert system. I have attached an example workbook (Excel 2003) for easier understanding.

On sheet 1, column B4, I have a Data Validation List, whereby a user can select which area is being problematic. Column C is a free-text cell where they can type in a short message explaining what the problem is. Column D is a button that they click that will fire off an email to a group of managers.

Sheet 2 is a list of all the areas and the manager responsible for that area.

What I need is a one-button macro that will:

1) In Sheet 2 column A, automatically apply a filter, based on whatever is currently the value of Sheet 1, B4.(whatever the user selects from the dropdown list). This will possibly be a filter based on ActiveCell value, I think?

2) Send off an email to each manager of the area that has been filtered in step 1.

2.1) The contents of Sheet 1, B4 and C4 should be the body of the email.

Example:

To: John Smith(12345@smsprovider.com); Samuel Jackson(54321@smsprovider.com)
Subject: SMS (this subject is always fixed as, yes, it's actually sending a text message via email to the manager's cell phone)
Message:
Incident: (value of Sheet 1, B4)Lobby - (value of Sheet 1, C4)Strange man loitering in the lobby.

Is this possible?

I hope I've explained clearly enough what I need. I'm not great at that. :s

Thank you very kindly in advance for your assistance.

[Ken Puls]

Hi there, and welcome to the forum.

The following code should go in a standard module in your workbook (let me know if you need help placing that):

Sub SendAlerts()
    Dim nm As Name
    Dim sArea As String
    Dim sRecipients As String
    Dim sMsg As String
    Dim cl As Range
    Dim rngTable As Range
    'Capture key details
    With Worksheets("Sheet 1")
        sArea = .Range("B4")
        sMsg = .Range("C4")
    End With
    'Determine range to search for emails
    With Worksheets("Sheet 2")
        Set rngTable = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    'Get list of recipients
    For Each cl In rngTable
        If cl.Value = sArea Then
            sRecipients = sRecipients & cl.Offset(0, 1).Value & " (" & cl.Offset(0, 2).Value & ");"
        End If
    Next cl
    'Check if any recipients found
    If Len(sRecipients) > 0 Then
        sRecipients = Left(sRecipients, Len(sRecipients) - 1)
        'Send the email
        Call SendEmail(sRecipients, "SMS", sMsg)
    Else
        MsgBox "Sorry, no recipients found!"
    End If
End Sub
Sub SendEmail(sRecipients As String, sSubject As String, sBody As String)
'Macro Purpose: To send an email through Outlook
    Dim objOL As Object
    Dim objMail As Object
    'Turn on error handling
    On Error GoTo Cleanup
    'Bind to Outlook
    Set objOL = CreateObject("Outlook.Application")
    'Create a new email and send it
    Set objMail = objOL.CreateItem(0)    '0=olmailitem
    With objMail
        .To = sRecipients
        .Subject = sSubject
        .Body = sBody
        .Display
    End With
Cleanup:
    'Release all objects
    Set objMail = Nothing
    Set objOL = Nothing
    On Error GoTo 0
End Sub

You should then be able to link your button to the "SendAlerts" macro.

Once you're happy that it is working, change the line in the second routine from .Display to .Send and it will send automatically without previewing first.

[Ana Sheila Martins]

Many, many, MANY thanks. It works like a dream! Thank you so much.

Much appreciated

[Ana Sheila Martins]

Good morning again.

I've been testing this and it really does work perfectly. There's just one little thing. I would like it to include the contents of both cells B4 and C4 in the body of the email. Yet if I change this in the code, it errors. I'm clearly doing it wrong. Can you help?

sMsg = .Range("C4")

if I cange it

sMsg = .Range("B4:C4")

it shows "Run-time error '13': Type mismatch".


Thanks again

[Ana Sheila Martins]

Actually, I had a cup of coffee, sat down and THOUGHT....and I figured it out. There's probably a much easier way to do it but hey, I got it to work hehehe. I changed the following:

sMsg = .Range("B4") & .Range("C4")

and it now works beautifully. It now shows in the body of the email exactly what area is being reported, as well as a brief message.

Thank you again and best regards!

[Ken Puls]

There's probably a much easier way to do it

Actually, that's exatly what I would have done. Glad you got it working!

[marlenelondt]

Hi

Thanks for the code below, works perfect, one thing I want to know. How do i get rid of the following message box once I get to send:
Microsoft Office Outlook ... Allow Deny Help.

Thanks
Marlene

Hi there, and welcome to the forum.

The following code should go in a standard module in your workbook (let me know if you need help placing that):

Sub SendAlerts()
    Dim nm As Name
    Dim sArea As String
    Dim sRecipients As String
    Dim sMsg As String
    Dim cl As Range
    Dim rngTable As Range
    'Capture key details
    With Worksheets("Sheet 1")
        sArea = .Range("B4")
        sMsg = .Range("C4")
    End With
    'Determine range to search for emails
    With Worksheets("Sheet 2")
        Set rngTable = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    'Get list of recipients
    For Each cl In rngTable
        If cl.Value = sArea Then
            sRecipients = sRecipients & cl.Offset(0, 1).Value & " (" & cl.Offset(0, 2).Value & ");"
        End If
    Next cl
    'Check if any recipients found
    If Len(sRecipients) > 0 Then
        sRecipients = Left(sRecipients, Len(sRecipients) - 1)
        'Send the email
        Call SendEmail(sRecipients, "SMS", sMsg)
    Else
        MsgBox "Sorry, no recipients found!"
    End If
End Sub
Sub SendEmail(sRecipients As String, sSubject As String, sBody As String)
'Macro Purpose: To send an email through Outlook
    Dim objOL As Object
    Dim objMail As Object
    'Turn on error handling
    On Error GoTo Cleanup
    'Bind to Outlook
    Set objOL = CreateObject("Outlook.Application")
    'Create a new email and send it
    Set objMail = objOL.CreateItem(0)    '0=olmailitem
    With objMail
        .To = sRecipients
        .Subject = sSubject
        .Body = sBody
        .Display
    End With
Cleanup:
    'Release all objects
    Set objMail = Nothing
    Set objOL = Nothing
    On Error GoTo 0
End Sub

You should then be able to link your button to the "SendAlerts" macro.

Once you're happy that it is working, change the line in the second routine from .Display to .Send and it will send automatically without previewing first.