XL 2019 Envoyer mails, n’envoie pas toutes les lignes

Option Explicit

Sub Envoi_mails()
Dim Ws As Worksheet, OutApp As Object, OutMail As Object, DerLig&, i&

Set Ws = Worksheets("Envoi mails")
DerLig = Ws.Range("A" & Rows.Count).End(xlUp).Row

For i = 4 To DerLig
    If Ws.Range("H" & i).Value <> "NON" Then
        On Error Resume Next
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = Ws.Range("A" & i).Value
            .CC = Ws.Range("B" & i).Value
            .BCC = Ws.Range("C" & i).Value
            .Subject = Ws.Range("D" & i).Value
            .Body = Ws.Range("E" & i).Value
            
            If Ws.Range("F" & i).Value <> "" Then
                .Attachments.Add Ws.Range("F" & i).Value
            End If
            If Ws.Range("G" & i).Value <> "" Then
                .Attachments.Add Ws.Range("G" & i).Value
            End If
            
            .Send
        End With
    End If
Next i

MsgBox "Messages Envoyés"
Set OutMail = Nothing: Set OutApp = Nothing
End Sub