1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

Emailing multiple recipients from Excel Based off Cell Value Collate to one email

Discussion in 'Business Applications' started by susan40, Feb 25, 2013.

Thread Status:
Not open for further replies.
Advertisement
  1. susan40

    susan40 Thread Starter

    Joined:
    Feb 25, 2013
    Messages:
    4
    Hi This is a follow up to

    http://forums.techguy.org/business-...emailing-multiple-recipients-excel-based.html

    I would like to be able to do the same

    My excel sheet keeps a list of Email addresses on column B (with duplicate email addresses), and their particulars from column C (Item price, purchase date, etc) onwards.

    I need the vba to email multiple recipients (those with the "notification" column E field marked as yes) with their purchasing details in it. I need to collate each row with the same email address & marked Yes so that only one email is sent.

    eg: email will have in the body

    Your order are ready to collect:

    row 2 information
    row 5 information
    row 9 information


    It should also prevent multiple emails to the same email address. I would like not to have to change the Notification column to acheve this.

    Thank you for your help.
     
  2. XCubed

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    Hi Susan

    Is this spreadsheet used on an ongoing basis? i.e. once those clients flagged as "Y" have been notified you would need the "yes" changed to "Sent".

    Also, would it be possible to attach a sample file (with email addresses and any other personal information dummied up). This would help in developing a solution that will work for you.
     
  3. susan40

    susan40 Thread Starter

    Joined:
    Feb 25, 2013
    Messages:
    4
    Thanks for your time

    Yes the sheet will be used on an ongoing basis.

    I have attached file that I am working on.

    It not the same Column to check as mentioned above.

    The first cell to check is Column Q if this is empty then I need to sent an email using the address in column W

    But I also need to check if there are any other Quotes that need to be sentat the same time so they go together in the one email. So the 3 csmith get a list of the 3 item that are to be updated. Again collum Q must be empty.

    I would prefer not to change the empty cell in column Q until after theyhave responded so if no response has been receive the next time I send outemail it will still included the older ones that have not been responded to. As a work around I could change the information in Q to read sent then clearafter all email have been sent.

    The most important thing I 'm trying to solve is having information from each line appear in the same email
    I would also like the list top run in order from top to bottom at newquotes are add to the top.
     

    Attached Files:

  4. XCubed

    XCubed

    Joined:
    Feb 21, 2013
    Messages:
    520
    Hi Susan

    Sorry it took some time to get back to you. I was trying to come up with a clever way to get what you want and when nothing came to me I resorted to the brute method. Essentially, to make it easier to group the emails, I sorted everything by person. In order to get the order back to its original state I set up a new column that records the current order and uses that to re-sort back to the original.

    From there it wasn't too difficult to group the user emails. I'll attach my version of the XL file and include the new macro here. It still needs more work which I'll try to do tomorrow but in the meantime can you do some testing e.g. add more users, enter values in Q to check that they are skipped and anything else you can think of in terms of possible conditions that may arise.

    Here is the Macro

    Code:
    Sub MailsCombined()
    Application.ScreenUpdating = False
    'Get last row
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    'Set the original order
    Cells(1, lCol) = "Sort"
    For r = 2 To lRow
        Cells(r, lCol) = r
    Next r
     
    'Sort by requester
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("E2:E" & lRow), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Sheet1").Sort
            .SetRange Range(Cells(1, 1), Cells(lRow, lCol + 1))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
     
     
    'Loop through each row
     
    esubject = "Quote Project Update"
    For i = 2 To lRow
    eBody = "Please update me on the following projects" & vbNewLine
        nRepeat = WorksheetFunction.CountIf(Range("E2:E" & lRow), Cells(i, "E"))
            If nRepeat > 1 Then
                For n = 0 To nRepeat - 1
                    If Cells(i + n, "Q") = "" Then
                        eBody = eBody & Cells(i + n, "A") & vbNewLine
                    End If
                Next n
                        If eBody <> "Please update me on the following projects" & vbNewLine Then
                            sendto = Cells(i + n - 1, "W").Value
                            Set app = CreateObject("Outlook.Application")
                            Set itm = app.createitem(0)
     
                            With itm
                                .To = sendto
                                .Subject = "Quote Project Update"
                                .Body = "Hi " & Cells(i + n - 1, "E").Value & vbCrLf & vbCrLf & eBody
                                .display
                                '.send
                            End With
                            Set app = Nothing
                            Set itm = Nothing
                        End If
     
            i = i + nRepeat - 1
     
     
            Else
                    If Cells(i, "Q") = "" Then
                        eBody = eBody & Cells(i, "A") & vbNewLine
                            sendto = Cells(i, "W").Value
                            Set app = CreateObject("Outlook.Application")
                            Set itm = app.createitem(0)
     
                            With itm
                                .To = sendto
                                .Subject = "Quote Project Update"
                                .Body = "Hi " & Cells(i, "E").Value & vbCrLf & vbCrLf & eBody
                                .display
                                '.send
                            End With
                            Set app = Nothing
                            Set itm = Nothing
                    End If
            End If
    Next i
     
        'Sort by Original
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(2, lCol), Cells(lRow, lCol)), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Sheet1").Sort
            .SetRange Range(Cells(1, 1), Cells(lRow, lCol))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Range(Cells(1, lCol), Cells(lRow, lCol)).ClearContents
    End Sub
     

    Attached Files:

  5. susan40

    susan40 Thread Starter

    Joined:
    Feb 25, 2013
    Messages:
    4
    Thanks

    working great.

    thanks again.
     
  6. Sponsor

As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/1090938

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice