Copy Multiple Excel ranges into Multiple Emails - VBA

I am currently trying to automatically generate emails from an excel sheet, where there is a different range for every email.

I have currently managed to find code where i can generate x amount of emails to the people that i need too, but i can still only use the one selected range (using rangetoHtml)

Sub Email221()

    Dim oOutlook As Object
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim StrBody As String
    Dim StrBody2 As String
    Dim StrBody3 As String
    
    StrBody = "Please see below daily changes to release scope for Onyx Obsidian" & "<br>" & "<br>"
    StrBody2 = "Please see below daily changes to release scope for CORE" & "<br>" & "<br>"
    StrBody3 = "Please see below daily changes to release scope for Custody" & "<br>" & "<br>"


    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("ONYX OBSIDIAN").Range("A1:G325").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
        
    End If

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

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = Sheets("Details").Range("c7").Value
        .CC = ""
        .BCC = ""
        .Subject = " daily scope changes - ONYX/OBSIDIAN " & Format$(Date, "dd-mmm-yy")
        .HTMLBody = StrBody & RangetoHTML
        .Display
    End With
    On Error GoTo 0

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


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

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = Sheets("Details").Range("c4").Value
        .CC = ""
        .BCC = ""
        .Subject = "VET daily scope changes - CORE " & Format$(Date, "dd-mmm-yy")
        .HTMLBody = StrBody2 & RangetoHTML
        .Display
    End With
    On Error GoTo 0

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

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = Sheets("Details").Range("c6").Value
        .CC = ""
        .BCC = ""
        .Subject = "VET daily scope changes - Custody " & Format$(Date, "dd-mmm-yy")
        .HTMLBody = StrBody3 & RangetoHTML
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
        
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Open in new window


Using the following RangetoHTML Function

Function RangetoHTML()

    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"
    
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Set rng = Sheets("ONYX OBSIDIAN").Range("A1:G325").SpecialCells(xlCellTypeVisible)
    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

Open in new window


Any help would be greatly appreciated!  (or is it possible to rename the rangetoHtml function and recreate it for all the different ranges that i need to copy)
Pat CammAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Bill PrewCommented:
This should give you the idea.  You can pass the range into the routines as a parameter, and then have a driver routine for each of the ranges you want to email.  Here's a quick attempt to show you the idea, haven't tested so may need a little tweaking...

Sub Driver()
    Email221 Sheets("ONYX OBSIDIAN").Range("A1:G325").SpecialCells(xlCellTypeVisible)
    Email221 Sheets("ONYX OBSIDIAN").Range("A1:G325").SpecialCells(xlCellTypeVisible)
End Sub

Sub Email221(rng As Range)

    Dim oOutlook As Object
    Dim OutApp As Object
    Dim OutMail As Object
    Dim StrBody As String
    Dim StrBody2 As String
    Dim StrBody3 As String
    
    StrBody = "Please see below daily changes to release scope for Onyx Obsidian" & "<br>" & "<br>"
    StrBody2 = "Please see below daily changes to release scope for CORE" & "<br>" & "<br>"
    StrBody3 = "Please see below daily changes to release scope for Custody" & "<br>" & "<br>"

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = Sheets("Details").Range("c7").Value
        .CC = ""
        .BCC = ""
        .Subject = " daily scope changes - ONYX/OBSIDIAN " & Format$(Date, "dd-mmm-yy")
        .HTMLBody = StrBody & RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

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


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

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = Sheets("Details").Range("c4").Value
        .CC = ""
        .BCC = ""
        .Subject = "VET daily scope changes - CORE " & Format$(Date, "dd-mmm-yy")
        .HTMLBody = StrBody2 & RangetoHTML
        .Display
    End With
    On Error GoTo 0

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

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = Sheets("Details").Range("c6").Value
        .CC = ""
        .BCC = ""
        .Subject = "VET daily scope changes - Custody " & Format$(Date, "dd-mmm-yy")
        .HTMLBody = StrBody3 & RangetoHTML
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
        
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub


Function RangetoHTML(rng As Range)

    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"
    
    Dim OutApp As Object
    Dim OutMail As Object
    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

Open in new window


»bp
0
NorieVBA ExpertCommented:
Normally the RangeToHTML function takes as an argument the range you want to convert, it looks like the version you are using has hard-coded the range as Sheets("ONYX OBSIDIAN").Range("A1:G325").SpecialCells(xlCellTypeVisible).

If you convert the function to take a range argument, see below,  you can then pass the appropriate range to it for each email.
Function RangetoHTML(rng As Range)

    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"
    
    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

Open in new window

0
Pat CammAuthor Commented:
Hi Norie,

Forgive me, my VBA ability is average at best.......

to use the range function as you suggested,and i convert the function to take a range argument,How can i then pass the appropriate range to it for each email? would this mean changes to the Range to Html Macro or to the email generation macro?

Thanks
0
Introducing Cloud Class® training courses

Tech changes fast. You can learn faster. That’s why we’re bringing professional training courses to Experts Exchange. With a subscription, you can access all the Cloud Class® courses to expand your education, prep for certifications, and get top-notch instructions.

Bill PrewCommented:
@Pat Camm,

Did you take a look at my earlier post, I think it answers your questions...


»bp
0
Pat CammAuthor Commented:
@Bill

I tried to use your code but if im completely honest the use of the Sub drivers is beyond what i am capable of and i cant get my head around how it should be working

Any help you could offer would be greatly appreciated

Pat
0
Bill PrewCommented:
Sure, you had indicated that what had worked well for one email, but that you needed to send multiple emails with different ranges.  The easiest way to do that was to take the routines you had and adjust them slightly so that rather than hard coding the range inside each procedure, we pass it in as a parameter when we call the procedure.

Then, to send out multiple emails we just call your existing Email221() routine multiple times, pass in the different ranges each time.  I created the Driver procedure to demonstrate that approach.

This all assumes that the rest of the email is the same, like recipient?

How were you executing Email221() before?  You could just execute it multiple times there, or execute the new Driver() there instead.


»bp
0
NorieVBA ExpertCommented:
Pat

You would need to change the email generation code to pass the appropriate ranges for each email.

It might look something like this where I've used a different sheet but the same range for each email.
Option Explicit

Sub Email221()
Dim oOutlook As Object
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Dim StrBody2 As String
Dim StrBody3 As String
    
    StrBody = "Please see below daily changes to release scope for Onyx Obsidian" & "<br>" & "<br>"
    StrBody2 = "Please see below daily changes to release scope for CORE" & "<br>" & "<br>"
    StrBody3 = "Please see below daily changes to release scope for Custody" & "<br>" & "<br>"
    
    Set rng = Nothing
    
    On Error Resume Next
    Set rng = Sheets("ONYX OBSIDIAN").Range("A1:G325").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
    Else
        Set OutMail = OutApp.CreateItem(0)
        
        On Error Resume Next
        
        With OutMail
            .To = Sheets("Details").Range("c7").Value
            .CC = ""
            .BCC = ""
            .Subject = " daily scope changes - ONYX/OBSIDIAN " & Format$(Date, "dd-mmm-yy")
            .HTMLBody = StrBody & RangetoHTML(rng)
            .Display
        End With
            
        On Error GoTo 0
        
    End If
    
    Set rng = Nothing
    
    On Error Resume Next
    Set rng = Sheets("CORE").Range("A1:G325").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        
    Else
        Set OutMail = OutApp.CreateItem(0)
        
        On Error Resume Next
        
        With OutMail
            .To = Sheets("Details").Range("c4").Value
            .CC = ""
            .BCC = ""
            .Subject = "VET daily scope changes - CORE " & Format$(Date, "dd-mmm-yy")
            .HTMLBody = StrBody2 & RangetoHTML(rng)
            .Display
        End With
        
        On Error GoTo 0
        
    End If
    
    Set rng = Nothing
    
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        
        
        On Error Resume Next
        Set rng = Sheets("ONYX OBSIDIAN").Range("A1:G325").SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        Set OutMail = OutApp.CreateItem(0)
        
        On Error Resume Next
        
        With OutMail
            .To = Sheets("Details").Range("c6").Value
            .CC = ""
            .BCC = ""
            .Subject = "VET daily scope changes - Custody " & Format$(Date, "dd-mmm-yy")
            .HTMLBody = StrBody3 & RangetoHTML(rng)
            .Display
        End With
        
        On Error GoTo 0
        
    End If
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Function RangetoHTML(rng As Range)
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"
    
    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

Open in new window

0
Pat CammAuthor Commented:
This all assumes that the rest of the email is the same, like recipient?

Unfortunately not, all of the emails have a different Subject, body and recipients.....

Im pretty sure i know the answer to this, but am i able to name the rangetoHtlm functions? then recreate them so each email sub looks at a different function?

Thanks

Pat
0
Bill PrewCommented:
I don't think you would want multiple NameToHtml() procedures, since it's very easy to pass it the "rng" parm and let it work on whatever range you need.

If you were going to duplicate you could do that in the Email221() procedure, as Norie suggested.

Using my approach we could pass whatever other data will be different for each email from Driver() as well as the Range.  This is the most "modular" and results in less code to support.  But I appreciate it's a concept you aren't as comfortable with yet.


»bp
0
NorieVBA ExpertCommented:
Pat

So you would want something that takes all the relevant 'pieces', e.g. recipient(s), range, body etc., and then creates/sends the email?
0
NorieVBA ExpertCommented:
You could try something like this.
Option Explicit

Sub SendEmailWithRange(strRecipient As String, strSubject As String, strBody As String, rng As Range)
Dim oOutlook As Object
Dim OutApp As Object
Dim OutMail As Object

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

    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = strRecipient
        .CC = ""
        .BCC = ""
        .Subject = strSubject
        .HTMLBody = strBody & RangetoHTML(rng)
        .Display
    End With

    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Function RangetoHTML(rng As Range)
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"

    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

Open in new window


Which you could use like this, which is based on the first email/range from the original code.
Sub Email221()
Dim rngBody As Range

    On Error Resume Next
    Set rngBody = Sheets("ONYX OBSIDIAN").Range("A1:G325").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rngBody Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
    Else
        SendEmailWithRange Sheets("Details").Range("C7").Value, _
                           "Daily scope changes - ONYX/OBSIDIAN " & Format$(Date, "dd-mmm-yy"), _
                           "Please see below daily changes to release scope for Onyx Obsidian" & "<br>" & "<br>", _
                           rngBody
    End If
    
End Sub

Open in new window

For the other emails you would repeat the same code replacing the recipient, subject, body and range as required.
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.