How to add additional Criteria to Ron de Bruin's "Mail a row or rows to each person in a range" code?

C

chonchos

New Member
Joined
Nov 4, 2016
Messages
16
I toyed with this all day yesterday. Been working away at it all morning and still can't whip it. I think it will be relatively easy for someone with some VBA experience... I'm just not quite there.

So, basically, Ron de Bruin's code from this page works great. Does just what it's supposed to do based on what's written.

But, I would like the code to make the selection based on two criteria instead of one. So, not only do I want to send one email listing multiple issues based on a unique email address... I also want to only send the issues with a number "1" in the "Status" Column. Here is an example of what my data looks like right now.

[TABLE="class: grid, width: 900"]
<tbody>[TR]
[TD="align: center"]COMPANY NAME[/TD]
[TD="align: center"]EMAIL[/TD]
[TD="align: center"]Status[/TD]
[TD="align: center"]FIRST NAME[/TD]
[TD="align: center"]RO #[/TD]
[TD="align: center"]PN[/TD]
[TD="align: center"]DESCRIPTION[/TD]
[TD="align: center"]SERIAL #[/TD]
[/TR]
[TR]
[TD="align: center"]Company A[/TD]
[TD="align: center"]Acontact@email.com[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]Alpha[/TD]
[TD="align: center"]852904[/TD]
[TD="align: center"]15[/TD]
[TD="align: center"]ACCUMULATOR[/TD]
[TD="align: center"]27[/TD]
[/TR]
[TR]
[TD="align: center"]Company A[/TD]
[TD="align: center"]Acontact@email.com[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]Alpha[/TD]
[TD="align: center"]852906[/TD]
[TD="align: center"]34[/TD]
[TD="align: center"]ACCUMULATOR[/TD]
[TD="align: center"]51[/TD]
[/TR]
[TR]
[TD="align: center"]Company A[/TD]
[TD="align: center"]Acontact@email.com[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]Alpha[/TD]
[TD="align: center"]852849[/TD]
[TD="align: center"]42[/TD]
[TD="align: center"]TACH GENERATOR[/TD]
[TD="align: center"]40[/TD]
[/TR]
[TR]
[TD="align: center"]Company B[/TD]
[TD="align: center"]Bcontact@email.com[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]Bravo[/TD]
[TD="align: center"]852657[/TD]
[TD="align: center"]36[/TD]
[TD="align: center"]HEATER, OIL TO FUEL[/TD]
[TD="align: center"]17[/TD]
[/TR]
[TR]
[TD="align: center"]Company B[/TD]
[TD="align: center"]Bcontact@email.com[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]Bravo[/TD]
[TD="align: center"]852764[/TD]
[TD="align: center"]12[/TD]
[TD="align: center"]GOVERNOR, OVERSPEED[/TD]
[TD="align: center"]35[/TD]
[/TR]
[TR]
[TD="align: center"]Company B[/TD]
[TD="align: center"]Bcontact@email.com[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]Bravo[/TD]
[TD="align: center"]852798[/TD]
[TD="align: center"]33[/TD]
[TD="align: center"]GOVERNOR, OVERSPEED[/TD]
[TD="align: center"]32[/TD]
[/TR]
[TR]
[TD="align: center"]Company B[/TD]
[TD="align: center"]Bcontact@email.com[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]Bravo[/TD]
[TD="align: center"]852987[/TD]
[TD="align: center"]9[/TD]
[TD="align: center"]HEATER, OIL TO FUEL[/TD]
[TD="align: center"]2[/TD]
[/TR]
[TR]
[TD="align: center"]Company B[/TD]
[TD="align: center"]Bcontact@email.com[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]Bravo[/TD]
[TD="align: center"]852983[/TD]
[TD="align: center"]20[/TD]
[TD="align: center"]HEATER, OIL TO FUEL[/TD]
[TD="align: center"]37[/TD]
[/TR]
[TR]
[TD="align: center"]Company B[/TD]
[TD="align: center"]Bcontact@email.com[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]Bravo[/TD]
[TD="align: center"]852413[/TD]
[TD="align: center"]38[/TD]
[TD="align: center"]GOVERNOR, OVERSPEED[/TD]
[TD="align: center"]49[/TD]
[/TR]
[TR]
[TD="align: center"]Company B[/TD]
[TD="align: center"]Bcontact@email.com[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]Bravo[/TD]
[TD="align: center"]852845[/TD]
[TD="align: center"]39[/TD]
[TD="align: center"]VALVE, FLOW DIVIDER[/TD]
[TD="align: center"]13[/TD]
[/TR]
[TR]
[TD="align: center"]Company B[/TD]
[TD="align: center"]Bcontact@email.com[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]Bravo[/TD]
[TD="align: center"]852872[/TD]
[TD="align: center"]52[/TD]
[TD="align: center"]GOVERNOR, OVERSPEED[/TD]
[TD="align: center"]46[/TD]
[/TR]
[TR]
[TD="align: center"]Company C[/TD]
[TD="align: center"]Ccontact@email.com[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]Charlie[/TD]
[TD="align: center"]852703[/TD]
[TD="align: center"]37[/TD]
[TD="align: center"]PROBE, FUEL QTY[/TD]
[TD="align: center"]5[/TD]
[/TR]
[TR]
[TD="align: center"]Company C[/TD]
[TD="align: center"]Ccontact@email.com[/TD]
[TD="align: center"]0[/TD]
[TD="align: center"]Charlie[/TD]
[TD="align: center"]852822[/TD]
[TD="align: center"]3[/TD]
[TD="align: center"]IVSI[/TD]
[TD="align: center"]44[/TD]
[/TR]
[TR]
[TD="align: center"]Company C[/TD]
[TD="align: center"]Ccontact@email.com[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]Charlie[/TD]
[TD="align: center"]850998[/TD]
[TD="align: center"]43[/TD]
[TD="align: center"]INDICATOR, FUEL FLOW[/TD]
[TD="align: center"]50[/TD]
[/TR]
[TR]
[TD="align: center"]Company C[/TD]
[TD="align: center"]Ccontact@email.com[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]Charlie[/TD]
[TD="align: center"]852444[/TD]
[TD="align: center"]11[/TD]
[TD="align: center"]PROBE, FUEL[/TD]
[TD="align: center"]41[/TD]
[/TR]
</tbody>[/TABLE]

Currently, based on the data above, I would get 3 emails (one for Company A, one for Company B, one for Company C) and each of those emails would list ALL of the RO#, PN, Description, and Serial #'s (Company A would list 3, Company B would list 8, Company C would list 4).

I would like the 3 emails still but I only want Company A to list the line with PN 42/Serial 40, Company B would list the lines with PN 38/Serial 49, PN 39/Serial 13, and PN 52/Serial 46, and Company C would list lines with PN 43/ Serial 50 and PN 11/Serial 41.

If, for example, Company D was listed but Status lines were "0" (or other than 1), then Company D does not generate a blank email.

I think I need to adjust or add to the code highlighted below, but I just can't figure out how to get it to do what I want!

Can some Excel VBA guru throw me a quick bone on this one so I don't open a crater in the wall banging my head into it? :banghead: Please!

Code: 
Sub Send_Row_Or_Rows_2()'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer


    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = ActiveSheet


[COLOR=#ff0000][B]    'Set filter range and filter column (column with e-mail addresses)[/B][/COLOR]
[COLOR=#ff0000][B]    Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)[/B][/COLOR]
[COLOR=#ff0000][B]    FieldNum = 2    'Filter column = B because the filter range start in column A[/B][/COLOR]

[COLOR=#ff0000][B]    'Add a worksheet for the unique list and copy the unique list in A1[/B][/COLOR]
[COLOR=#ff0000][B]    Set Cws = Worksheets.Add[/B][/COLOR]
[COLOR=#ff0000][B]    FilterRange.Columns(FieldNum).AdvancedFilter _[/B][/COLOR]
[COLOR=#ff0000][B]            Action:=xlFilterCopy, _[/B][/COLOR]
[COLOR=#ff0000][B]            CopyToRange:=Cws.Range("A1"), _[/B][/COLOR]
[COLOR=#ff0000][B]            CriteriaRange:="", Unique:=True[/B][/COLOR]
            


    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))


    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount


            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value


            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then


                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With


                Set OutMail = OutApp.CreateItem(0)


                On Error Resume Next
                With OutMail
                    .to = Cws.Cells(Rnum, 1).Value
                    .Subject = "Test mail"
                    .HTMLBody = RangetoHTML(rng)
                    .Display  'Or use Send
                End With
                On Error GoTo 0


                Set OutMail = Nothing
            End If


            'Close AutoFilter
            Ash.AutoFilterMode = False


        Next Rnum
    End If


cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub


 


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook


    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With


    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With


    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")


    'Close TempWB
    TempWB.Close savechanges:=False


    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Sort by date Sort by votes
Hi chonchos,

You can add a filter for the Status criteria like this...

Code: 
   'Filter the FilterRange on the FieldNum column
   FilterRange.AutoFilter Field:=FieldNum, _
                          Criteria1:=Cws.Cells(Rnum, 1).Value
   
[COLOR="#0000CD"]   '--also filter Status field for "1" values
   FilterRange.AutoFilter Field:=3, Criteria1:="1"[/COLOR]

   'If the unique value is a mail addres create a mail
   If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
 
Upvote 0
So, I still need/want some help on this one... but about 5 hours later I'm a little closer than I've been yet!

I added/changed the Bold Red items in the code below. So now it's creating the emails and its only showing the data that I want it to show! Awesome!

BUT! It's also creating emails for the "blank" items still. So I get an email with headers and no details. I'd rather it just NOT create "blank" emails.

If someone wants to hop in on this part or even offer a better solution than what I came up with I am all ears!

If not, hopefully I'll have the second part figured out before another 5 hours elapses. ;)

Code: 
'Set filter range and filter column (column with e-mail addresses)    Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
    FieldNum = 2    'Filter column = B because the filter range start in column A
[COLOR=#ff0000][B]    FieldNum2 = 3[/B][/COLOR]




    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:=[COLOR=#ff0000][B]Range("AA1:AA2")[/B][/COLOR], Unique:=True
            


    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))


    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount


              'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, Criteria1:=Cws.Cells(Rnum, 1).Value
[B][COLOR=#ff0000]            FilterRange.AutoFilter Field:=FieldNum2, Criteria1:="yes"[/COLOR][/B]


            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
 
Upvote 0
Hey Jerry! I was typing up my post just as you were submitting yours, it seems.

Looks like I was pretty **** close!

Any thoughts on the blank emails issue?

Jerry Sullivan said:
Hi chonchos,

You can add a filter for the Status criteria like this...

Code: 
   'Filter the FilterRange on the FieldNum column
   FilterRange.AutoFilter Field:=FieldNum, _
                          Criteria1:=Cws.Cells(Rnum, 1).Value
   
[COLOR=#0000CD]   '--also filter Status field for "1" values
   FilterRange.AutoFilter Field:=3, Criteria1:="1"[/COLOR]

   'If the unique value is a mail addres create a mail
   If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
Click to expand...
 
Upvote 0
chonchos said:
Hey Jerry! I was typing up my post just as you were submitting yours, it seems.

Looks like I was pretty **** close!

Any thoughts on the blank emails issue?
Click to expand...

Two options...
1. Modify the first AdvancedFilter call to include the Status="yes" criteria. That ensures that each unique name will have at least one item when the AutoFilter is applied.

2. Keep the AdvancedFilter step as is, but add a check after the AutoFilter step to count visible rows besides the header. You can use this code to count visible rows.

Code: 
   With FilterRange
      lVisibleRowCount = Application.Subtotal(3, .Range("A2:A" & .Rows(.Rows.Count).End(xlUp).Row))
   End With
 
Upvote 0
Alright.

So, I thought I added the criteria as outlined in option 1.

The original code is:

Code: 
Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _ 
            CriteriaRange:="", Unique:=True

I changed the code to the following:

Code: 
 Set Cws = Worksheets.Add    
FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:=[COLOR=#ff0000][B]Range("AA1:AA2")[/B][/COLOR], Unique:=True

The Criteria being in cell AA1 and AA2, like so:

[TABLE="class: grid, width: 100"]
<tbody>[TR]
[TD]#[/TD]
[TD]AA[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Status[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]yes[/TD]
[/TR]
</tbody>[/TABLE]


Is there something I am missing or perhaps I've just done it completely wrong?

Also, I tried to add option 2 immediately after the last line in the code posted above... no dice. Does it need to be placed somewhere else?
 
Last edited:
Upvote 0
You were close. :)

1. The range being advance filtered needs to contain both the Email and Status fields.
2. The criteria range needs to reference sheet Ash. Without that, it uses the activesheet when the line is executed, which is the added temporary sheet.

Code: 
 Set Cws = Worksheets.Add
 Ash.Columns(FieldNum).Resize(, 2).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:=Ash.Range("AA1:AA2"), Unique:=True
 
Upvote 0
What a day and it's only 12:30!

I finally got around to working on this again. I attempted both options again.

First I tried the code you referenced in your last post . I made the adjustments and ran it. My results included the blank email still... AND it spit out multiple emails to the same address instead of individual emails for unique addresses. So, kind of a step backward?

Then I went back and tried to add the With FilterRange code from Post #5 . I thought maybe the first time I tried it I placed it in the wrong section. So I tried it like this:

Code: 
    'Filter the FilterRange on the FieldNum column            FilterRange.AutoFilter Field:=FieldNum, Criteria1:=Cws.Cells(Rnum, 1).Value
            FilterRange.AutoFilter Field:=FieldNum2, Criteria1:="yes"
[COLOR=#ff0000][/COLOR]
[COLOR=#ff0000][B]            With FilterRange[/B][/COLOR]
[COLOR=#ff0000][B]            lVisibleRowCount = Application.Subtotal(3, .Range("A2:A" & .Rows(.Rows.Count).End(xlUp).Row))[/B][/COLOR]
[COLOR=#ff0000][B]            End With[/B][/COLOR]


            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
            'And Cws.Cells(Rnum, 2).Value = "yes"

I get the emails with the correct data... but I also still get the "blank emails".

So then I tried adding it after the first set of "FilterRange code" like this:

Code: 
 'Add a worksheet for the unique list and copy the unique list in A1    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:=Range("AA1:AA2"), Unique:=True
            
[COLOR=#ff0000][B]            With FilterRange[/B][/COLOR]
[COLOR=#ff0000][B]            lVisibleRowCount = Application.Subtotal(3, .Range("A2:A" & .Rows(.Rows.Count).End(xlUp).Row))[/B][/COLOR]
[COLOR=#ff0000][B]            End With[/B][/COLOR]

Same thing, details on the email are right, but I still get the blank.

So it almost seems like it has no effect no matter where I place it.

:\

You wouldn't happen to have any other suggestions, would you? :)
 
Upvote 0
Thanks for providing a link to your example workbook.

Two problems in that workbook...

1. It's not using the exact code that I suggested in Post #7 (only references one column).

2. There's no criteria in AA1:AA2 of the worksheet.

If you fix those things, it should work for you.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Ron de Bruin VBA
Replies
2
Views
2K
Alexfoots
A
C
  • Question Question
Conditional Formatting from several sheets using Ron de Bruin
Replies
1
Views
868
cactus_ritter
C
D
  • Question Question
VBA to Create Outlook Email Not Working for All Users
Replies
9
Views
364
Logit
Logit
C
  • Question Question
VBA - Email specific range and attach Sheet1
Replies
4
Views
898
Clermont
C
E
  • Question Question
This code is to put a excel range onto a email
Replies
3
Views
577
I_know_nuffin
I

Forum statistics

Threads
1,224,822
Messages
6,181,165
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top