Macro de Excel para extraer el encabezado y las filas y luego enviarlas por correo electrónico

Estoy tratando de encontrar una macro de Excel que obtenga los encabezados de una tabla y luego copie ciertas filas en un correo electrónico.

Por ejemplo

State  |  Store  |  Points
Store1 |  VIC    |  3201
Store2 |  NSW    |  1234
Store3 |  QLD    |  4234

Tengo el siguiente código, que me permite seleccionar toda la tabla, y se copia en el correo electrónico y lo envía, aunque lo necesito automatizado para extraer las filas individuales

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Sub Mail_Selection_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").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")
    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
     "\Microsoft\Signatures\Default.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "email@address"
        .CC = ""
        .BCC = ""
        .Subject = "My Subject here"
        .HTMLBody = "<i></i> Hi<br/>" & _
        "Please find below a summary of activity.<br/><h3>National Summary</h3>" & _
        RangetoHTML(rng) & Signature
        .Send   'or use .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)
' 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

Lo que necesito es que el código copie las filas de una Tienda específica en el correo electrónico para que solo la información de la Tienda esté en el mensaje. ¿Cómo puedo hacer esto para cada valor único en la Statecolumna?

Está creando el archivo HTML a partir de la hoja UsedRange.

'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

Después de configurarlo Sheet:=TempWB.Sheets(1).Name, podría declarar otra variable de rango para capturar SOLO las filas necesarias para cada tienda, y luego usarla como Source:=.

Su código no funciona en mi Excel 2010, así que desafortunadamente no puedo verificarlo, pero en lugar de usar el usedRange, debería poder especificar una dirección de rango en otra variable.

Ejemplo:

Sub PublishObjectFromFilteredRange()
'An example of applying autofilter to sheet
' and setting range variable = to the autofiltered cells/visible cells
Dim ws As Worksheet
Dim storeID As String
Dim tableRange As Range
Dim filteredRange As Range
Dim pObj As PublishObject
Set ws = Sheets("Sheet1")

'Define the range of the table
Set tableRange = ws.Range(Range("A1").End(xlDown), Range("A1").End(xlToRight))

'Define the Store for which you want to create the report
storeID = "Store 1" '<---- change this as necessary

'Set a filter on the table
tableRange.AutoFilter Field:=1, Criteria1:=storeID

'determine the visible table range
Set filteredRange = tableRange.Cells.SpecialCells(xlCellTypeVisible)

'Create & publish the PublishObject
Set pObj = ActiveWorkbook.PublishObjects.Add( _
    SourceType:=xlSourceRange, _
    Filename:="C:\Users\david_zemens\Desktop\publish.htm", _
    sheet:="Sheet1", _
    Source:=filteredRange.Address, _
    HtmlType:=xlHtmlStatic)

    pObj.Publish True


End Sub