XL 2016 Boucle ne fonctionne pas lors d'un envoi des plusieurs mail

Sub envoi_mails()

'envoi mail
ActiveWorkbook.Save
'Feuil16.Range("I2").Value = Destinataire.Value
  Dim ListeDest()
  Dim ListeComment()
  Dim i As Long
  Dim oMsgApp As Object
  Dim oMsg As Object
  Dim sListeDest As String
  Dim sFichier As String
   'déclarer les variable
  Dim a As Variant, name As String
  'Dim li As String
  name = ActiveWorkbook.name
  ChDir ThisWorkbook.Path ' & "\" & "Formulaire_Dm"
  'si fichier selectionné ouvrir en arrière plan outlook
  Set oMsgApp = CreateObject("Outlook.Application")

  ListeDest() = Range("Tableau2[Mail]")
  ListeComment() = Range("Tableau2[Commentaire]")
   'sFichier = Range("Tableau2[joint]")
 
   li = Sheets("Base destinataire_formulaire").Cells(3600, 1).End(xlUp).Row ' a partir de la ligne 36000 TROUVE LA 1ER CELLULE VIDE EN REMONTANT DANS LA COLONNE 1 (a)
For i = 2 To li
sFichier = Sheets("Base destinataire_formulaire").Cells(i, 6).Value


Next

  For i = LBound(ListeDest(), 1) To UBound(ListeDest(), 1)
    Set oMsg = oMsgApp.CreateItem(0)
    With oMsg
      .To = ListeDest(i, 1)
      .Attachments.Add sFichier 'fichier en pc jointe
      .Subject = "Votre Formulaire de rénouvellement" ' : " & ActiveSheet.Range("B15").Value & " _ " & ActiveSheet.Range("E9").Value & " _ " & ActiveSheet.Range("I27").Value 'objet du mail
      .Body = "Bonjour" & Chr(10) & Chr(13) & _
        ListeComment(i, 1) & Chr(10) & Chr(13) & "Restant à votre disposition"
      .Send
    End With
    Set oMsg = Nothing
  Next

  oMsgApp.Quit
  Set oMsgApp = Nothing
  MsgBox " Mails envoyés avec succés "


End Sub

 li = Sheets("Base destinataire_formulaire").Cells(3600, 1).End(xlUp).Row ' a partir de la ligne 36000 TROUVE LA 1ER CELLULE VIDE EN REMONTANT DANS LA COLONNE 1 (a)
For i = 2 To li
sFichier = Sheets("Base destinataire_formulaire").Cells(i, 6).Value