XL 2019 Placer ou remplacer une photo .jpg au-dessus de la cellule [B6] contenant du texte à conserver

For Each forme In ActiveSheet.Shapes
   If forme.Name Like "Image*" Then forme.Delete
Next forme

Set Sha = Wsh.Shapes.AddPicture(File, False, True, [B6].Left, [B6].Top, [F1].Width, [F1].Height)

Sub Trombino()
' Origine de la macro :
' #12 - AtTheOne et avec l'apport de Job75
' https://excel-downloads.com/threads/placer-mes-photos-dans-la-colonne-a-a3-a4-etc-jusquen-a99-selon-le-prenom-et-le-nom-colonnes-b-et-c.20087816/
Dim Fso As Object, DC As Object
Dim Wsh As Worksheet, RépTrombi As String
Dim DébNoms As Range, DébPhotos As Range, Cible As Range
Dim Sha As Shape, s As Shape, File As Variant

    Set Wsh = Feuil1 'c'est la Sheets("Liste caissiers")
    Set DébNoms = Wsh.[B2]   'première cellule contenant les noms
    Set DébPhotos = Wsh.[E2]
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set DC = CreateObject("Scripting.Dictionary")
    RépTrombi = ThisWorkbook.Path & "\TROMBINOSCOPE"
'
    Application.ScreenUpdating = False
 
    ' PARTIE A
    ' *******************************************************************************
    ' Supprimer l'ancienne photo quand le prénom [B4] est changé
    For Each s In ActiveSheet.Shapes
        On Error Resume Next
        If Left(s.Name, 9) <> "Drop Down" Then
            If Not Application.Intersect(s.TopLeftCell, ActiveSheet.[B6]) Is Nothing Then
                s.Delete
                On Error GoTo 0
            End If
        End If
    Next

    ' PARTIE B
    ' *******************************************************************************
    ' placer la photo
    If [L5] = "Avec Photo" Then
'        Application.ScreenUpdating = False
        For Each File In Fso.GetFolder(RépTrombi).Files 'Fso.GetFolder([PhotoDir]).Files
            If File.Name = [B4] & " " & [C4] & ".jpg" Then
                ' *******************************************************************************
                ' Avec cette ligne, la photo se place en [A1] mais ne supprime pas la précédente
                Set Sha = Wsh.Shapes.AddPicture(File, False, True, [B6].Left, [B6].Top, [B6:D6].Width, [B6:B7].Height)

                ' *******************************************************************************
                ' Cette ligne ne fonctionne pas
                ' Danger : elle supprime le texte dans [B6]
                ' Cells(6, 2) = Fso.getBasename(File) 'le nom de la photo

                ' *******************************************************************************
                ' Cette ligne ne fonctionne pas
'                PlaceThePictureInCenterRange Cells(6, 2), Shapes.AddPicture(File, False, True, 20, 20, -1, -1), 90

                ' *******************************************************************************
                ' Avec cette ligne, la photo se place se rapproche, avec '400' de [B6] sans aller sur [6]
                ' mais ne supprime pas la photoprécédente
'                Set s = Wsh.Shapes.AddPicture(File, False, True, [F1].Top, 400, [F1].Width, [F1].Height)

'                Sha.LockAspectRatio = True 'proportions concervées

                Set s = Nothing
            End If
        Next
        Set Fso = Nothing ' Libération mémoire
    End If

'    Application.ScreenUpdating = True

End Sub

Set Sha = Wsh.Shapes.AddPicture(File, False, True, [B6].Left, [B6].Top, [B6].Width, [B6:B7].Height)