VBA L'envoi ne se fait que pour la 1ère ligne.

Bonjour,

je souhaite envoyer des états pdfs via un fichier excel qui récence les mails et les fichiers à envoyer
j ai récupéré la macro ci dessous
Elle fonctionne au problème prêt qu'elle envoie seulement la première ligne
Pourriez vs svp m'aider ?
merci
Sub envoiPJ_Fichier()

Dim olapp As Outlook.Application
Sheets("destinataires").Select
Range("A11").Select
Do While Not IsEmpty(ActiveCell)
Dim msg As MailItem
Set olapp = New Outlook.Application
Set msg = olapp.CreateItem(olMailItem)
msg.To = ActiveCell.Value
msg.Subject = Range("A2").Value
msg.Body = ActiveCell.Offset(0, 1).Value & " " & ActiveCell.Offset(0, 2).Value & " " & ActiveCell.Offset(0, 3).Value & Chr(13) & Chr(13) & ActiveCell.Offset(0, 4).Value & Chr(13) & Range("A5").Value & Chr(13) & Chr(13) & ActiveCell.Offset(0, 5).Value & Chr(13) & Range("A8").Value
'-- pj
ActiveCell.Offset(0, 6).Select
Do While Not IsEmpty(ActiveCell)
nf = ActiveWorkbook.Path & "\" & ActiveCell.Value
msg.Attachments.Add Source:=nf
ActiveCell.Offset(0, 1).Select
Loop
msg.Display
Loop
End Sub