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

[chonchos]

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.

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

<tbody>
</tbody>

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? Please!

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

 

[chonchos]

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

 

[Jerry Sullivan]

No worries friend! Glad to hear it is working for you now.