Reports

The following routine inserts/removes the results of a couple of formulas. Those formulas return a table that contains only three columns (that you noted) and where the value in ON BUY is <=1.

Sub email_range()
Dim OutApp As Object
Dim OutMail As Object
Dim pop As Range
Dim strl As String
Dim sOnBuy As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'''Based on your comment, we know that your table starts with A1
Set pop = Cells(1, 1).CurrentRegion
'''get/store the address for the On Buy header column
With pop.Cells(1, 1).Offset(0, pop.Columns.Count + 1)
    .Formula2 = "=ADDRESS(1,MATCH(""ON BUY""," & pop.Rows(1).Address & ",0))"
    sOnBuy = .Value
    .delete
End With

'''create the table that you'll insert into the email
With pop.Cells(1, 1).Offset(0, pop.Columns.Count + 1)
    '''use a formula to return the table headers
    '''and based on the criteria (On Buy<=1)
    .Formula2 = "=VSTACK(FILTER(" & pop.Rows(1).Address & ",(" & _
        pop.Rows(1).Address & "=""Item"")+(" & _
        pop.Rows(1).Address & "=""Description"")+(" & _
        pop.Rows(1).Address & "=""On Buy"")" & _
        "),FILTER(FILTER(" & _
        pop.Address & ",(" & _
        pop.Rows(1).Address & "=""Item"")+(" & _
        pop.Rows(1).Address & "=""Description"")+(" & _
        pop.Rows(1).Address & "=""On Buy"")" & _
        "), " & sOnBuy & ":" & Left(sOnBuy, 3) & pop.Rows.Count & "<=1))"
    Set pop = .CurrentRegion
End With
With pop
    .Copy
    .PasteSpecial xlPasteValues
    '''apply table formatting
    ActiveSheet.ListObjects.Add(xlSrcRange, pop, , xlYes).name = "emailTable"
End With

strl = "<BODY style = font-size:12pt;font-family:Calibri>" & _
"Hello all, <br><br> Can you advise<br>"

On Error Resume Next

With OutMail

.To = "[email protected]"
.CC = ""
.BCC = ""
.Subject = "Remove"
.display
.HTMLBody = strl & RangetoHTML(pop) & .HTMLBody

End With

pop.delete

On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

79494436