Email a range of excel cells using VBA produces infinite loop HELP

Hi everyone, this is my first time posting here... I am creating a payroll file in which I am trying to send a range of cells to the emails addresses of our employees. I get it to do everything fine except the loop does not end and ends up reproducing the emails. All help is welcome. My coding constructs may not be the best.
The excel sheet currently contains 170 rows to be emailed. It will grow so just wanted to put that out there.

Sub SendMailsFromList()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim rng As Range
    Dim Ash As Worksheet
    Dim ws As Worksheet
    Dim ebody As String
    Dim i As Integer
    
    ebody = "See below for your pay information for this pay period. If there are any errors please reach out to your team coach/supervisor." & "<br>"
    
    Set Ash = ActiveWorkbook.ActiveSheet
    
    On Error GoTo cleanup
    
    Set OutApp = CreateObject("Outlook.Application")

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    For i = 1 To 171
    
    For Each cell In Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
            Ash.Range("A1:AC171").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 = "Payroll file"
                .HTMLBody = ebody & RangetoHTML(rng)
                .Display
            End With
            On Error GoTo 0

            Set OutMail = Nothing
            Ash.AutoFilterMode = False
            
            cell.Offset(1, 0).Select
Next i

cleanup:
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
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"
 
    '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