XL 2010 VBA macro - Afficher des photos avec hauteur & largeur fixe\proportionnel

Sub ChargeTrombinoscope()
Dim Chemin As String, Fichier As String
Dim Nom, Prénom As String
Dim splitArr() As String
Dim Ligne As Integer
  
Worksheets("Pix").Activate

  'Définit le répertoire contenant les fichiers
Chemin = "C:\test-20160928\MyPH\"
  
  'Boucle sur tous les fichiers du répertoire (photos).
Ligne = 3
Columns("K:K").ColumnWidth = 172  ' défini la largeur de la colonne

Fichier = Dir(Chemin & "*")
Do While Len(Fichier) > 0
  'Extraction prénom
  splitArr = Split(Fichier, ".")
  Prénom = splitArr(0)
  Range("H" & Ligne).Value = Prénom
  'insertion de la photo dans la colonne K
  Range("K" & Ligne).Select
  

  ActiveSheet.Pictures.Insert(Chemin & Fichier).Select
  ActiveCell.RowHeight = 100  ' ajuste la hauteur de la ligne : 1 point = 0,035 cm
  With Selection.ShapeRange
  .Left = ActiveCell.Left
  .Top = ActiveCell.Top
  .Height = 100  ' ajuster la hauteur : 1 point = 0,035 cm
'  .Width = 150  ' ou la largeur
  .LockAspectRatio = msoTrue  ' conserve le proportion de l'image
  End With
  Range("H3").Select
  
  'Fichier suivant
  Fichier = Dir()
  Ligne = Ligne + 1
Loop
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ZoneRecep As Range
Dim Cel As Range
Dim Sh As Shape
Dim PosX As Double, PosY As Double

  If Target.Count > 1 Then Exit Sub
  If Target.Row Mod 7 <> 0 Then Exit Sub                  ' Lignes 7, 14, 21, 28 ....
  If InStr(1, "159", Trim(Str(ActiveCell.Column))) Then   ' Colonnes A E I
    Set ZoneRecep = Cells(Target.Row - 3, Target.Column)
    With Application
      .ScreenUpdating = False
      '.EnableEvents = False
    End With
  
    ' Recherche dans les images si une est présente dans la zone recep
    For Each Sh In ActiveSheet.Shapes
      If Sh.Type = msoPicture Then
        If Sh.TopLeftCell.Row = ZoneRecep.Row Then   ' Même ligne : 1er filtre
          If Sh.TopLeftCell.Column >= ZoneRecep.Column And Sh.TopLeftCell.Column < ZoneRecep.Offset(0, 1).Column Then
            Sh.Delete
            Exit For
          End If
        End If
      End If
    Next Sh
  
    If Target = "" Then Exit Sub    ' Aucun numéro on quitte
  
    ' C'est la macro qui fera la recherche
    Set Cel = Sheets("Pix").Columns("B").Find(what:=Target, LookIn:=xlValues, lookat:=xlWhole)
    If Not Cel Is Nothing Then
      Set Sh = Sheets("Pix").Shapes(Cel.Offset(0, 1))
      PosX = ZoneRecep.Left + ((ZoneRecep.Offset(0, 1).Left - ZoneRecep.Left) / 2) - Sh.Width / 2
      PosY = ZoneRecep.Top + ((ZoneRecep.Offset(1, 0).Top - ZoneRecep.Top) / 2) - Sh.Height / 2
      Sheets("Pix").Shapes(Cel.Offset(0, 1)).Copy
      ActiveSheet.Paste ZoneRecep
      With Selection                                      ' Pour 2007 et plus
      'With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)  ' Pour 2003
        .Top = PosY
        .Left = PosX
      End With
      Target.Select
    Else
      MsgBox "No corresponding picture"
    End If
  End If
End Sub