Does anyone know how to Emails Ranges instead of Emailing Rows.

[bloodmilksky]

Hi Guys, I hope you are all well today

I have been using the below to fire off emails to customers. So their Account number appears in Column A & their email in Column B and it then sends off information row by row (C3:I3) to each customer.

What I was wondering if anyone knows how I may Amend this code to email named ranges instead of rows.

So the ranges would be A1:B10,C1:D10,E1:F10 and so on with their account number in A1 & email in B1 and information below.

Sub EmailRanges()
' Defines variables
Dim OutlookApp As Object, Mess As Object, SendAddress As String, Cell As Range, cRange As Range


' Disable screen updating
Application.ScreenUpdating = False


' Defines LastRow as the last row of column A containing data
LastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row


' Sets the range to check for email addresses
Set cRange = ActiveSheet.Range("B3:B" & LastRow)


' For each cell in the check range
For Each Cell In cRange
    ' If the cell is not blank then
    If Cell.Value <> "" Then
        ' The desired send address will be the cell value
        SendAddress = Cell.Value
        ' Select the range of cells on the active worksheet.
        ActiveSheet.Range("C" & Cell.Row, "I" & Cell.Row).Select
        ' Show the envelope on the ActiveWorkbook.
        ActiveWorkbook.EnvelopeVisible = True
        ' Set the optional introduction field thats adds
        ' some header text to the email body. It also sets
        ' the To and Subject lines. Finally the message
        ' is sent.
        With ActiveSheet.MailEnvelope
            .Introduction = "Good Morning"
            .Item.To = SendAddress
            .Item.Subject = "Just testing this macro sorry for filling you inbox ^_^ "
            .Item.Send
        End With
    End If
' Check next cell in the check range
Next Cell


' Re-enable screen updating
Application.ScreenUpdating = True


MsgBox "The Customers Have Been Notified"
End Sub

Any help would be greatly appreciated

Many thanks

Bloodmilksky

 

[bloodmilksky]

Yeah of course anything really at this point LOL

and thankyou so much for your help

 

[Worf]

Try this:

Sub EmailRanges()
Dim cr As Range, outapp As Object, outmail As Object
Set cr = [b1]
Set outapp = CreateObject("Outlook.Application")
Do While cr <> ""
    Set outmail = outapp.CreateItem(0)
    With outmail
        .To = cr
        .Subject = "Just testing, sorry for filling you inbox ^_^ "
        .HTMLBody = RangetoHTML(cr.Offset(, -1).Resize(20, 2))
        '.Send                                              ' to send
        .Display                                            ' to test
    End With
    Set cr = cr.Offset(, 2)
Loop
Application.ScreenUpdating = True
Set outmail = Nothing:    Set outapp = Nothing
MsgBox "The Customers Have Been Notified"
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
Dim fso As Object, ts As Object, TempFile As String, TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to paste 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=")
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

 

[bloodmilksky]

Hi Worf,

it is sending the first range and then just erroring again.

 

[Worf]

Hi

What line of code is highlighted? What is the error number and message?