none
Email multiple users based on result of applied filter RRS feed

  • Question

  • Good morning,

    I need a little help with a project for an Incident Alert System that I am working on. In a nutshell, it's a single-line interface where a user will select an area from a Data Validation Dropdown List in Column B4. Cell C4 is free-text, where they can write a short description of the problem. Cell D4 is where the macro button is. This is all on sheet 1.

    Sheet 2 is a hidden sheet that contains a list of areas and their respective managers. One area can have more than one manager.

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

    1) In Sheet 2 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); Jane Doe(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.

    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.


    • Edited by Anathera Thursday, November 3, 2011 1:16 PM
    Thursday, November 3, 2011 1:15 PM

Answers

  • I have assumed your list of areas is in column A of sheet 2, and the SMS addresses are in column B.

    Set a reference to Outlook, and use code like this from the button in column D:

    Sub EmailContact()
        Dim c As Range
        Dim myAdd As String
        Dim myFindString As String
        Dim firstAddress As String
        Dim ol As Object
        Dim myItem As Object

        myFindString = Worksheets("Sheet 1").Range("B4").Value
       
        With Worksheets("Sheet 1").Range("A:A")
            Set c = .Find(myFindString, LookIn:=xlValues, lookAt:=xlWhole)

            If Not c Is Nothing Then
                firstAddress = c.Address
                myAdd = c.Offset(0, 1).Value
            End If

            Set c = .FindNext(c)
            If Not c Is Nothing And c.Address <> firstAddress Then
                Do
                    myAdd = myAdd & ", " & c.Offset(0, 1).Value
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With

        Set ol = CreateObject("outlook.application")
        Set myItem = ol.CreateItem(olMailItem)
       
        myItem.To = myAdd
        myItem.Subject = "SMS"
        myItem.Body = "Incident: " & Worksheets("Sheet 1").Range("B4").Value & _
                      " - " & Worksheets("Sheet 1").Range("C4").Value
        myItem.Send
        Set myItem = Nothing
        Set ol = Nothing

    End Sub


    HTH, Bernie
    • Marked as answer by Anathera Friday, November 4, 2011 9:20 AM
    Thursday, November 3, 2011 4:33 PM

All replies

  • I have assumed your list of areas is in column A of sheet 2, and the SMS addresses are in column B.

    Set a reference to Outlook, and use code like this from the button in column D:

    Sub EmailContact()
        Dim c As Range
        Dim myAdd As String
        Dim myFindString As String
        Dim firstAddress As String
        Dim ol As Object
        Dim myItem As Object

        myFindString = Worksheets("Sheet 1").Range("B4").Value
       
        With Worksheets("Sheet 1").Range("A:A")
            Set c = .Find(myFindString, LookIn:=xlValues, lookAt:=xlWhole)

            If Not c Is Nothing Then
                firstAddress = c.Address
                myAdd = c.Offset(0, 1).Value
            End If

            Set c = .FindNext(c)
            If Not c Is Nothing And c.Address <> firstAddress Then
                Do
                    myAdd = myAdd & ", " & c.Offset(0, 1).Value
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With

        Set ol = CreateObject("outlook.application")
        Set myItem = ol.CreateItem(olMailItem)
       
        myItem.To = myAdd
        myItem.Subject = "SMS"
        myItem.Body = "Incident: " & Worksheets("Sheet 1").Range("B4").Value & _
                      " - " & Worksheets("Sheet 1").Range("C4").Value
        myItem.Send
        Set myItem = Nothing
        Set ol = Nothing

    End Sub


    HTH, Bernie
    • Marked as answer by Anathera Friday, November 4, 2011 9:20 AM
    Thursday, November 3, 2011 4:33 PM
  • Thank you very much for this. It works perfectly!
    Friday, November 4, 2011 9:19 AM
  • Then I hope you caught my error on this!

     With Worksheets("Sheet 1").Range("A:A")

    which should have been

     With Worksheets("Sheet 2").Range("A:A")


    HTH, Bernie
    Friday, November 4, 2011 2:28 PM