Autres Erreur de suppression de ligne quand une cellule contient une valeur

Bonjour,

A l'aide d'une macro je supprime des lignes et des images contenues sur ces lignes, tout fonctionne bien sauf si la dernière ligne contient une valeur. Valeur mise avec une zone de liste déroulante de contrôle formulaire. Il m'efface bien toutes les images et toutes les lignes sauf la dernière ligne si elle est pleine ou il provoque une erreur. J'ai beau cherché, je ne trouve pas. j'ai essayé plein de façon de supprimer les images et les lignes c'est toujours pareil.
Merci pour votre aide

Sub supprimer_la_piece()
Application.ScreenUpdating = False
NomBoutonSupprimerPiece = ActiveSheet.Shapes(Application.Caller).Name
PositionBoutonSupprimerPiece = ActiveSheet.Shapes(NomBoutonSupprimerPiece).TopLeftCell.Address
PositionLogo = Range(PositionBoutonSupprimerPiece).Offset(0, -7).Address
PositionDelete = Range(PositionBoutonSupprimerPiece).Offset(1, -7).Address
Do While Range(PositionDelete).Value = "" And Range(PositionDelete).Offset(1, 0).Value <> "" And Range(PositionDelete).Offset(1, 0).Value <> "Fin" Or Range(PositionDelete).Value <> "" And Range(PositionDelete).Offset(1, 0).Value = "" And Range(PositionDelete).Offset(1, 0).Value <> "Fin" Or Range(PositionDelete).Value <> "" And Range(PositionDelete).Offset(1, 0).Value <> "" And Range(PositionDelete).Offset(1, 0).Value <> "Fin"
Range(PositionLogo).EntireRow.Delete
Loop
Dim Image As Shape
For Each Image In ActiveSheet.Shapes
If Not Intersect(Image.TopLeftCell, Range(PositionBoutonSupprimerPiece).EntireRow) Is Nothing Then ' <- erreur affichée ici mais il exécute la macro jusqu'à la dernière ligne
Image.Delete
End If
Next Image
Range(PositionBoutonSupprimerPiece).EntireRow.ClearContents
Range(PositionDelete).EntireRow.Delete
Range(PositionDelete).Offset(-1, 0).EntireRow.Delete
Application.CutCopyMode = False
Range(PositionDelete).Offset(2, 7).Select
End Sub