Thread: Non contiguous cells selection in a Range in Excel for Emailing with Outlook 2007

Dear Old Chums ,
See I am still at it..made a little progress but going on ..here is the mutilated code I want to edit ..attached is the dummy sheet sheet .Just need to sort out the range issue for now ..

Sub DataEnterprise()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim myRange As Range
    Dim R1 As Range
    Dim R2 As Range
    Dim R3 As Range
    Dim LR As Long
    Dim eRng As Range
    Dim eCell As Range
    myRange.Formula = "=RAND()"
    'Find last row with data in Column N (Email Addresses)
   ' LR = Range("N" & Rows.Count).End(xlUp).Row
    'LR = Range("M" & Rows.Count).End(xlUp).Row
    LR = Range("L" & Rows.Count).End(xlUp).Row
    

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    
    'Set the range of Email Addresses
    'Set eRng = Range("N2:N" & LR)
    Set eRng = Range("L2:L" & LR)
    
    'Cycle through each cell in Column N (each Email Address)
    For Each eCell In eRng

        If eCell.Value <> "" And _
                eCell.Offset(0, -2).Value = "Active" _
                Or eCell.Offset(0, -2).Value = "Active " Then

            '     If cell.Value Like "?*@?*.?*" And _
                  '         (Cells(cell.Row, "E").Value) = "Active" Then


            'This is the Table Headers
            'Set R1 = Range("E1:K1")
            Set R1 = Range("C1,e1,i1")
            
            
            'This is the Table Detail
            'Set R2 = eCell.Offset(0, -9).Resize(1, 7)
            Set R2 = eCell.Offset(0, -9).Resize(1, 3)
            
            
            'This is the Bottom Border of the Table
            'Set R3 = Range("E1").End(xlDown).Offset(1, 0).Resize(1, 7)
            Set R3 = Range("C1").End(xlDown).Offset(1, 0).Resize(1, 3)
            
            
            'This creates the Table from above
            Set myRange = Union(R1, R2, R3)


            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = eCell.Value
                '.CC = eCell.Offset(0, 1)
                .CC = "OverDue"
                .BCC = eCell.Offset(0, 2)
                '.Subject = "Balance: " & eCell.Offset(0, -13) & " - " & eCell.Offset(0, -12) & " - " & eCell.Offset(0, -11)
                .Subject = "Over Due Invoices: " & eCell.Offset(0, -11) & " - " & eCell.Offset(0, -10) & " - " & eCell.Offset(0, -9)
                '.HTMLBody = "<H4>Dear " & eCell.Offset(0, 3).Value & "</H4>" & _
                        '"Hope you are fine<BR>" & _
                        '"<BR>Please find below the current status<BR>" & _
                        '"of your account" & _
                        '"<H4><U>Balance Summary</U></H4>" & _
                        'RangetoHTML(Rng) & _
                        '"<BR>Today's position is:<h3><font color =red > over the limit</font></h3>Request you to make immediate payment.For queries please revert or call, I will be glad to assist. <BR>" & _
                        ''"<BR>Best Regards<BR>" & _
                        '"<H4>" & eCell.Offset(0, -10).Value & "</H4>" & _
                        ''"<H4>India</H4></BR>"
                    .HTMLBody = "<H4>" & [DE!B3] & " " & eCell.Offset(0, -1).Value & "," & "</H4>" & _
                    [DE!B4] & "<BR>" & "<BR>" & [DE!B5] & "<BR>" & [DE!B6] & _
                    "<H4><U>" & [DE!B7] & "</U></H4>" & RangetoHTML(myRange) & _
                    "<BR>" & [DE!B9] & "    " & Format(Date, "mmmm  dd , yyyy") & _
                    "   " & [DE!C9] & "<h4><font color =red >" & "<u>" & [DE!B10] & _
                    "   $ " & eCell.Offset(0, -3).Value & "</u>" & "</h4>" & "</H5> </font> </h5>" & [DE!B11] & "<BR>" & "</H5>" & [DE!B12] & _
                    [DE!B13] & "</H5>" & [DE!B14] & "</H5>" & "<H4>" & [DE!B15] & "<H4>" & "<H4>" & [DE!B16] & "</H4>" & "<H4>" & [DE!B17] & "</H4>" & "<H4>" & [DE!B18] & "<H4>" & "<H4>" & [DE!B19] & "<H4> "
                    
                    
                    
                    
                    ' Sheets name must be the same ! body and not Body !

                '.Send  'Or use
                .Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next eCell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub
Function RangetoHTML(Rng As Range)
'29/01/2011, RB: sourced from http://www.rondebruin.nl/mail/folder3/row2.htm
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    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

Thanks in advance ...T-10 ,B ,J
Regards
N

Hello,

although you may feel that we are all your "Dear Old Chums", please be aware that not everybody here is familiar with questions you may have posted earlier.

Above, you post code and mention a "range issue". You don't describe what the issue is. If you are interested in a solution, you'd benefit greatly from not assuming that everyone here is familiar with the situation.

Please describe the problem in the post narrative and don't expect members to either be familiar with your situation or spend considerable time on creating a sample file to run your code and figure out what the issue is in the first place.

cheers,

hi Nutty,

Please note that Teylyn is just completing her voluntary responsibilities and that John (& perhaps me?) have already suggested that...

Originally Posted by jaslake

...PS: should you start a new thread, provide a link to other threads that you feel are appropriate to your issue.

Can you please provide a link to your previous thread so that anyone who so desires can easily become familiar with the situation?

I'm sorry I don't have time to look at your file in detail at the moment. However, after glancing at your posted code, I recommend that you read through every line of code within the "For Each eCell In eRng" Loop. If any line does/returns exactly the same thing for every loop iteration, move the code so that it is only performed once (before the Loop begins). For example, the "Headers" & "bottom border" sections.

btw, I suspect there are still a few tips that you can still learn from the previous thread

hth
Rob

Hi Nutty
I support Rob's comments. Your thread title and initial file posted gave no indication of your issue. Had I not been familiar with your previous posts, I'd not even looked at it.

You need to help us help you. Give us ALL the information...don't assume we KNOW. Give us TOO MUCH information...we'll sift through the detritus.

See attached.

Dear All,
@ Ms Teylyn,
...Now what kind of man will ever be rude to a lady ...Was it me ???.. well I must have been knocked off or may be close to being dead to do so ..humour apart I am sorry for being not nice to you ...hell ..a lady deserves respect and I better give it to her ..Cheers .. N
@ R
always love you for driving home a point in best way possible
@ J
..thanks for all your help always..I owe you a beer

Hi Nutty

For some reason I seem to have lost your PM so I can't respond to it. I recall from the PM you want to send emails ONLY to "Yes" and that you were looking for the border around the last item.

You also asked if you should post an updated file with your new requirements. Well, perhaps yes, perhaps no.

If you wish to send to ONLY "Yes" recipients, why do we have the "No" code? Are you suggesting you wish to CHOOSE to whom to send...either "Yes" OR "No"...or BOTH?

Explain what you need, perhaps I can help.

Hi Nutty

Should be a rather simple fix...I'll get back to you.

Hi Nutty

I think I misread your post. See if this does as you require. By the way, the code should be in a General Module.

Hi Nutty

Regarding this

Hey I need your advice for a larger problem It's part of the entire configration ..would you be able to suggest ..help ..right now I am working in peicemeal basis and it still leaves a lot to be desired ...I can e mail you my working

I'd STRONGLY suggest you keep it on the Forum. You've got hundreds of better qualified individuals than I to assist you. If you wish I be involved, simply PM me that you've posted a new Thread...I'll look at it.