Macro-send row of excel through outlook

Dear All

below mention code copy row from excel and paste to outlook email body,it
send only one row, i want if there is one email id in B column and 4 rows belongs to that mailid it will copy 4 rows.
if column B is Blank then it will copy from that row till find next value in B column.
Excel Sheet Data
A B C D E
Name Email ID Yes/No Location ID
A [email protected] yes ABC 1541
B [email protected] yes ABC 1541
C [email protected] yes ABC 1541
C yes ABC 1541
C yes ABC 1541
C yes ABC 1541

<code>
Option Explicit

Sub Send_Row()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range
Dim Ash As Worksheet
Dim StrBody As String
Dim StrhBody As String
StrBody = "Dear Sir/Madam," & "<br>" & _
"Line 1" & "<br>" & _
"Line 2" & "<br>" & _
"Line 3" & "<br><br><br>"
StrhBody = "Line A" & "<br>" & _
"Line B" & "<br>" & _
"Line C" & "<br><br>"
Set Ash = ActiveSheet
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

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

For Each cell In Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" Then

Ash.Range("A1:O100").AutoFilter Field:=2, Criteria1:=cell.Value


With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With


Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = cell.Value

.Subject = "Test Mail"

.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & StrhBody
.Display 'Or use Send
End With
On Error GoTo 0

Set OutMail = Nothing
Ash.AutoFilterMode = False
End If
Next cell

cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub