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
 
Sort by date Sort by votes
I am irritated beyond belief right now.

So, I swear on my life and all things holy that I put your code in EXACTLY as you had it, ran the code, and it didn't work. I swear it happened. Swear it. I even tried it more than once!

Now, when I setup the sample workbook I did forget to add the referenced criteria cells. I also changed the "non-working" code back to what I had in there originally. So that's definitely my bad.

I was about to hop on here and say "you got it all wrong bud, here's what happened, I'm telling you, man, that code doesn't work!" etc.

But I wanted to be absolutely sure "I was right" before I started typing up my reply.

So I tried the code from post 7 again, just absolutely sure it would fail again.

Nope. Works like a charm.

I don't know what I did or didn't do originally. But the code from post 7 DEFINITELY works and I guess I just had to hold my fingers right to get it to work right or something. I don't know!

But thank you so much for your help with this! And sorry for being a pain when this could have been "solved" yesterday! Oops! :D
 
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
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,164
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