Probléme codage VBA envoi mail

Bonjour à tous,

Je suis en train de créer des macros sur mon outil de pilotage de la sécurité.
J'ai réussi à créer la macro pour envoyer par mail les informations précises que j'ai restitué dans mon tableau excel cependant je souhaiterais avoir un bouton par ligne.
Actuellement, il me génère un mail pour toutes les lignes de mon tableau.

Voici mon code :

Private Sub Envoi_mail_Click()
Dim i As Integer
With Sheets("Presque OUF")
For i = 3 To .[A65536].End(xlUp).Row ' on passe en revue toutes les lignes de la colonne A
'objet du mail
sujet = "Nouvelle feuille XXXXXX"
'corps du mail
message = "Bonjour, vous trouverez les informations concernant une nouvelle fiche incident." & vbCr & "Lieu : " & .Cells(i, "E") & vbCr & "Description : " & .Cells(i, "G") & vbCr & "Préconisations éventuelles :" & vbCr & .Cells(i, "AA") & vbCr & vbCr & "Merci de me tenir informée des actions à effectuer ainsi que du délai de mise en place." & vbCr & "Cordialement," & vbCr & "Justine XXX, XXXXXXXX"
'adresse mail destinataire
adresse = .Cells(i, "AD")
Set OutlookApp = CreateObject("outlook.application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.Subject = sujet 'sujet du mail
.To = adresse 'adresse mail destinataire
.Body = message 'corps du message
.Display 'affiche le mail
End With
Next

End With

End Sub

Que dois-je modifier pour qu'il me génère un mail ligne par ligne et non toutes les lignes d'un coup ?

Merci d'avance de votre aide.