Copying two ranges into an outlook email from excel using VBA (Most of the code already done)

Question

This is my first post here, so please be nice!

I have an excel file with a pretty cool macro i made using snippets of code I found online (mostly from Excel MVP Ron de Bruin).

What it does is copy data from a range (not yet formatted as a table because the code doesn't support that, but it may have to be) and does a VLookup to create temporary workbooks with data pertaining to only a specific person's name. Then it references a mapping sheet and sends an outlook email to those people. It's pretty awesome.

It works perfectly now, when there's only one data-set on the page. My problem comes, however, when there are two objects on the page, because it does not carry over column headings.

If you look at my attached image of the file (https://i.stack.imgur.com/K6LSC.jpg), I have both North American and European Sample Data, with some names overlapping. I need the distinct column headings to carry over, so the person recieving the email knows the difference between NA data and European Data.

The email it generates looks like this: (https://i.stack.imgur.com/0mDHU.jpg) As you see, the second entry doesn't make sense because it took place under a different header.

  Option Explicit

    Sub Send_Row_Or_Rows_Attachment_1()
    'Working in 2000-2013
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
        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
        Dim mailAddress As String
        Dim NewWB As Workbook
        Dim TempFilePath As String
        Dim TempFileName As String
        Dim FileExtStr As String
        Dim FileFormatNum As Long

        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

        'Set filter range and filter column (column with names)
        Set FilterRange = Ash.Range("A5:H" & Ash.Rows.Count)
        FieldNum = 1    'Filter column = A because the filter range start in column A

        'Add a worksheet for the unique list and copy the unique list in A1
        Set Cws = Worksheets.Add
        FilterRange.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=Cws.Range("A1"), _
                CriteriaRange:="", Unique:=True

        '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

                'Look for the mail address in the MailInfo worksheet
                mailAddress = ""
                On Error Resume Next
                mailAddress = Application.WorksheetFunction. _
                    VLookup(Cws.Cells(Rnum, 1).Value, _
                              Worksheets("Mailinfo").Range("A1:B" & _
                                    Worksheets("Mailinfo").Rows.Count), 2, False)
                On Error GoTo 0

                If mailAddress <> "" Then

                    'Filter the FilterRange on the FieldNum column
                    FilterRange.AutoFilter Field:=FieldNum, _
                                           Criteria1:=Cws.Cells(Rnum, 1).Value

                    'Copy the visible data in a new workbook
                    With Ash.AutoFilter.Range
                        On Error Resume Next
                        Set rng = .SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0
                    End With

                    Set NewWB = Workbooks.Add(xlWBATWorksheet)

                    rng.Copy
                    With NewWB.Sheets(1)
                        .Cells(1).PasteSpecial Paste:=8
                        .Cells(1).PasteSpecial Paste:=xlPasteValues
                        .Cells(1).PasteSpecial Paste:=xlPasteFormats
                        .Cells(1).Select
                        Application.CutCopyMode = False
                    End With

                    'Create a file name
                    TempFilePath = Environ$("temp") & "\"
                    TempFileName = "Your data of " & Ash.Parent.Name _
                                 & " " & Format(Now, "dd-mmm-yy h-mm-ss")

                    If Val(Application.Version) < 12 Then
                        'You use Excel 97-2003
                        FileExtStr = ".xls": FileFormatNum = -4143
                    Else
                        'You use Excel 2007-2013
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If

                    'Save, Mail, Close and Delete the file
                    Set OutMail = OutApp.CreateItem(0)

                    With NewWB
                        .SaveAs TempFilePath & TempFileName _
                              & FileExtStr, FileFormat:=FileFormatNum
                        On Error Resume Next
                        With OutMail
                            .To = mailAddress
                            .Subject = "Test mail"
                            .Attachments.Add NewWB.FullName
                            .HTMLBody = RangetoHTML(rng)
                            .Display  'Or use Send
                        End With
                        On Error GoTo 0
                        .Close savechanges:=False
                    End With

                    Set OutMail = Nothing
                    Kill TempFilePath & TempFileName & FileExtStr
                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)
    ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 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 workbook to receive the data.
        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 an .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 the RangetoHTML subroutine.
        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.
        Kill TempFile

        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function

Answer 1

After re-reading the question, I think the simplest way is to read down the original worksheet, each time a name is encountered for the first time to copy the whole sheet to a new workbook, name the sheet after the person and then delete all the other names from that sheet. That leaves us with a worksheet for each person with all the original headings and formats intact and we can then email it. So here is my code. I've not touched any of the emailing code.

I believe from the original code that the name of the person,e.g. "Jim", is what is used to lookup the email address and naming the sheet after the person makes it easy to get the name.

Option Explicit

Const NAME_HEADING As String = "Name"
'

Sub Send_Row_Or_Rows_Attachment_1()
'Working in 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim fullDataSheet As Worksheet
    Dim tempBook As Workbook
    Dim Cws As Worksheet
    Dim mailAddress As String
    Dim NewWB As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long

    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 fullDataSheet = ActiveSheet
    Set tempBook = Workbooks.Add(xlWBATWorksheet)

    CreateSheets fullDataSheet, tempBook

    ' Now loop through the sheets in tempBook and email each one
    For Each Cws In tempBook.Worksheets
        Set rng = Cws.UsedRange
        If rng.Row > 2 Then
            'Look for the mail address in the MailInfo worksheet
            mailAddress = ""
            On Error Resume Next
            mailAddress = Application.WorksheetFunction. _
                VLookup(Cws.Name, _
                          Worksheets("Mailinfo").Range("A1:B" & _
                                Worksheets("Mailinfo").Rows.Count), 2, False)
            On Error GoTo 0

            If mailAddress <> "" Then
                'Copy the data to a new workbook
                Set NewWB = Workbooks.Add(xlWBATWorksheet)

                rng.Copy

                With NewWB.Sheets(1)
                    .Cells(1).PasteSpecial Paste:=8
                    .Cells(1).PasteSpecial Paste:=xlPasteValues
                    .Cells(1).PasteSpecial Paste:=xlPasteFormats
                    .Cells(1).Select
                    Application.CutCopyMode = False
                End With

                'Create a file name
                TempFilePath = Environ$("temp") & "\"
                TempFileName = "Your data of " & fullDataSheet.Parent.Name _
                             & " " & Format(Now, "dd-mmm-yy h-mm-ss")

                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If

                'Save, Mail, Close and Delete the file
                Set OutMail = OutApp.CreateItem(0)

                With NewWB
                    .SaveAs TempFilePath & TempFileName _
                          & FileExtStr, FileFormat:=FileFormatNum
                    On Error Resume Next
                    With OutMail
                        .To = mailAddress
                        .Subject = "Test mail"
                        .Attachments.Add NewWB.FullName
                        .HTMLBody = RangetoHTML(rng)
                        .Display  'Or use Send
                    End With
                    On Error GoTo 0
                    .Close SaveChanges:=False
                End With

                Set OutMail = Nothing
                Kill TempFilePath & TempFileName & FileExtStr
            End If        ' If mailAddress <> ""
        End If        ' If rng.Row > 2
    Next Cws

cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    tempBook.Close SaveChanges:=False
    Application.DisplayAlerts = True

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

End Sub
Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 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 workbook to receive the data.
    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 an .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 the RangetoHTML subroutine.
    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.
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Private Sub CreateSheets(ByRef sourceSheet As Worksheet, ByRef newBook As Workbook)

' Reads down the sourceSheet looking at each name
' Looks for worksheet in newBook that already has this name
' If exists, move to next name
' If doesn't exist, then copies sourceSheet to newBook and
' then reads down the list deleting rows *not* for the current name

Dim thisCell As Range
Dim thisPersonsSheet As Worksheet
Dim thisName As String
Dim lastRow As Long

    lastRow = sourceSheet.UsedRange.Row + sourceSheet.UsedRange.Rows.Count

    Set thisCell = sourceSheet.Range("A1")

    Do While thisCell.Row <= lastRow
        thisName = Trim(thisCell.Value)
        ' Is this an actual name?
        If (thisName <> "") And (thisName <> NAME_HEADING) Then
            ' Has code already seen this name before
            If Not WorksheetExists(newBook, thisName) Then
                sourceSheet.Copy After:=newBook.Worksheets(newBook.Worksheets.Count)
                Set thisPersonsSheet = newBook.Worksheets(newBook.Worksheets.Count)
                thisPersonsSheet.Name = thisName
                ' Remove all other names from the sheet
                DeleteOtherNamesFromSheet thisPersonsSheet
            End If
        End If
        Set thisCell = thisCell.Offset(RowOffset:=1)
    Loop

End Sub

Private Sub DeleteOtherNamesFromSheet(ByRef thisPersonsSheet As Worksheet)

' Reads down the thisPersonsSheet looking at each name
' If matches name of the sheet or is NAME_HEADING or blank
' then leave, else deletes the row

Dim thisCell As Range
Dim thisPersonsName As String
Dim thisName As String
Dim lastRow As Long
Dim deleteRowAbove As Boolean

    lastRow = thisPersonsSheet.UsedRange.Row + thisPersonsSheet.UsedRange.Rows.Count

    Set thisCell = thisPersonsSheet.Range("A1")
    deleteRowAbove = False

    thisPersonsName = thisPersonsSheet.Name

    Do While thisCell.Row <= (lastRow + 1)
        If deleteRowAbove Then
            thisCell.Offset(RowOffset:=-1).EntireRow.Delete
            deleteRowAbove = False
        End If

        thisName = Trim(thisCell.Value)
        ' Is this an actual name that is *not* this person?
        If (thisName <> "") And (thisName <> NAME_HEADING) And (thisName <> thisPersonsName) Then
            deleteRowAbove = True
        End If
        Set thisCell = thisCell.Offset(RowOffset:=1)
    Loop

End Sub

Private Function WorksheetExists(ByRef theWorkbook As Workbook, ByRef sheetName As String) As Boolean

' Returns True if a worksheet named 'sheetName' exists in theWorkbook

On Error Resume Next ' In case the worksheet does not exist

Dim wks As Worksheet
Dim result As Boolean

    Set wks = theWorkbook.Worksheets(sheetName)

    If (wks Is Nothing) Then
        Err.Clear
        result = False
    Else
        result = True
    End If

    WorksheetExists = result

End Function