XL 2019 Insérer une image en fonction de valeur cellule mais sur plusieurs lignes

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim C As Range, Sh As Shape, Plage As Range
  If Target.Column <> 2 Then Exit Sub
  With Sheets("DATABASE")
    Set Plage = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
  End With
  With Sheets("OFFER_TEMPLATE")
    If Target.Value = "" Then
      For Each Sh In .Shapes
        If Sh.TopLeftCell.Address = Target.Address Then
          Sh.Delete
        End If
      Next Sh
    Else
'      On Error Resume Next
      For Each C In Plage
        If C = Target Then
          For Each Sh In Sheets("DATABASE").Shapes
            If Sh.TopLeftCell.Address = C.Offset(, 2).Address Then
              Sh.Copy
              Exit For
            End If
          Next Sh
          Exit For
        End If
      Next C
      Target.Offset(, 1).PasteSpecial
'      On Error GoTo 0
    End If
  End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim C As Range, Sh As Shape, Plage As Range
  If Target.Column <> 2 Then Exit Sub
  If Target.Count > 1 Then Exit Sub
  With Sheets("DATABASE")
    Set Plage = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
  End With
  With Sheets("OFFER_TEMPLATE")
    For Each Sh In .Shapes
      If Sh.Type <> msoFormControl Then
        If Sh.TopLeftCell.Address = Target.Offset(, 1).Address Then
          Sh.Delete
        End If
      End If
    Next Sh
    If Target.Value <> "" Then
      For Each C In Plage
        If C = Target Then
          For Each Sh In Sheets("DATABASE").Shapes
            If Sh.TopLeftCell.Address = C.Offset(, 2).Address Then
              Sh.Copy
              Exit For
            End If
          Next Sh
          Exit For
        End If
      Next C
      Target.Offset(, 1).PasteSpecial
    End If
  End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range("B7:B" & Rows.Count), UsedRange)
If Target Is Nothing Then Exit Sub
Dim i As Variant, a$, o As Object
Application.ScreenUpdating = True
Application.CopyObjectsWithCells = True 'si ce n'est pas le cas
With Sheets("DATABASE")
    Columns(3).ColumnWidth = .Columns(4).ColumnWidth 'même largeur
    For Each Target In Target 'si entrées/effacements multiples
        a = Target(1, 2).Address
        For Each o In DrawingObjects
            If o.TopLeftCell.Address = a Then o.Delete
        Next o
        i = Application.Match(Target, .Columns(2), 0)
        If IsNumeric(i) Then
            Target.RowHeight = .Rows(i).RowHeight 'même hauteur
            .Cells(i, 4).Copy Target(1, 2) 'copie la cellule et l'objet
            Target(1, 2).Borders.LineStyle = xlNone 'supprime les bordures
        End If
    Next Target
End With
End Sub

Set Target = Intersect(Target, Range("B7:B" & Rows.Count), UsedRange)