Sub DeleteLastOccurence()

    Const strKeyWord As String = "Delete"
    Dim rngPicture  As Range
    Dim rngJunk As Range

    Set objDoc = ActiveDocument
    objDoc.InlineShapes(1).Delete

    Do
        On Error Resume Next
        Set rngPicture = objDoc.InlineShapes(objDoc.InlineShapes.Count).Range
        Set rngJunk = objDoc.Range(0, rngPicture.Start)
        rngJunk.Find.Execute FindText:=strKeyWord, Forward:=False
        On Error GoTo 0

        If rngJunk.Find.Found = True Then
            objDoc.Range(rngJunk.Start, rngPicture.End).Delete
        Else
            Exit Do
        End If

    Loop While True

End Sub