XL 2019 ActiveSheet.Paste ne fonctionne pas

Option Explicit

Sub Images()
    Dim F As Worksheet, d As Object, c As Range, s As Shape, mem
    Dim elem, rond
    Set F = Feuil2    'CodeName, à adapter
    Application.ScreenUpdating = False
    Application.CopyObjectsWithCells = True    'au cas où...
    F.DrawingObjects.Placement = 2    'Déplacer sans dimensionner avec les cellules
    Set d = CreateObject("Scripting.Dictionary")
    For Each c In F.UsedRange.SpecialCells(xlCellTypeConstants)
        If c.Column = 14 Then Set d("14" & c.Value) = F.Range("N2")    'cellule à adapter
        If c.Column = 15 Then Set d("15" & c.Value) = F.Range("O2")    'cellule à adapter
    Next c
    For Each elem In d
        Debug.Print elem; "  "; TypeName(d(elem))
    Next
    With ActiveSheet
        For Each s In .Shapes
            If s.Name Like "AutoShape*" Or s.Name Like "Oval*" Then s.Delete
        Next s
        For Each c In .UsedRange.SpecialCells(xlCellTypeConstants)
            rond = False
            If d.exists("15" & c.Value) Then
                mem = c
                d("15" & c.Value).Copy c    'copie/colle la cellule avec son objet
                c = mem
                rond = True
            End If

            If d.exists("14" & c.Value) Then
                With Feuil2.Shapes("AutoShape 13")
                    If rond = True Then .Left = Feuil2.[O2].Left - 30 Else Feuil2.Shapes("AutoShape 13").Left = Feuil2.[O2].Left - 20
                End With
                mem = c
                d("14" & c.Value).Copy c    'copie/colle la cellule avec son objet
                c = mem
            End If
      Next c
    End With
End Sub

Sub Images()
Dim F As Worksheet, d As Object, c As Range, s As Shape, mem
Set F = Feuil2 'CodeName, à adapter
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où...
F.DrawingObjects.Placement = 2 'Déplacer sans dimensionner avec les cellules
Set d = CreateObject("Scripting.Dictionary")
For Each c In F.UsedRange.SpecialCells(xlCellTypeConstants)
    If Application.CountIf(F.UsedRange, c) = 1 Then
        If c.Column = 14 Then Set d(c.Value) = F.Range("N2") 'cellule à adapter
        If c.Column = 15 Then Set d(c.Value) = F.Range("O2") 'cellule à adapter
    Else
        Set d(c.Value) = F.Range("P2") 'doublon, cellule à adapter
    End If
Next c
With ActiveSheet
    For Each s In .Shapes
        If s.Name Like "AutoShape*" Or s.Name Like "Oval*" Then s.Delete
    Next s
    For Each c In .UsedRange.SpecialCells(xlCellTypeConstants)
        If d.exists(c.Value) Then
            mem = c
            d(c.Value).Copy c 'copie/colle la cellule avec son objet
            c = mem
        End If
    Next c
End With
End Sub

                    If item1.Column = 14 Then
                        Set s = sh(1).Duplicate
                        s.Name = "x": s.Copy: Factive.Paste
                        With ActiveSheet.Shapes.Range(Array(s.Name))
                            .Top = item2.Top
                            .Left = item2.Left
                            .Name = sh(1).Name
                        End With

                        Set s = sh(2).Duplicate
                        s.Name = "x": s.Copy: Factive.Paste
                        ' Fonctionne pas
                        With s 
                            .Select
                            .Top = item2.Top
                            .Left = item2.Left + item2.Width - .Width
                            .Name = sh(2).Name
                        End With

Sub testbisNettoyer()
' ********************************************************************
Dim FGroupSemaine As Worksheet
    Set FGroupSemaine = Worksheets("Groupe semaine")
Dim Rg1 As Range
    Set Rg1 = Union(FGroupSemaine.Range(FGroupSemaine.Cells(1, 14), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 14).End(xlUp).Row, 14)), FGroupSemaine.Range(FGroupSemaine.Cells(1, 15), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 15).End(xlUp).Row, 15)))
Dim item1 As Range
Dim sh(1 To 2) As Shape
Set sh(1) = FGroupSemaine.Shapes("AutoShape 13")
Set sh(2) = FGroupSemaine.Shapes("Oval 93")
' ********************************************************************
Dim Factive As Worksheet
    Set Factive = Worksheets(ActiveSheet.Name)
Dim Rg2 As Range
    Set Rg2 = Union(Factive.Range(Factive.Cells(1, 3), Factive.Cells(Factive.Cells(65536, 3).End(xlUp).Row, 3)), Factive.Range(Factive.Cells(1, 5), Factive.Cells(Factive.Cells(65536, 5).End(xlUp).Row, 5)), Range(Factive.Cells(1, 7), Factive.Cells(Factive.Cells(65536, 7).End(xlUp).Row, 7)))
' *******************************************************************

Dim s As Shape
For Each s In Factive.Shapes
    If s.Name = sh(1).Name Or s.Name = sh(2).Name Then
        s.Delete
    End If
Next s

Dim item2 As Range
    For Each item2 In Rg2
        If item2.Value <> Empty Then
            For Each item1 In Rg1
                If item1.Value = item2.Value Then
                    If item1.Column = 14 Then
                        Set s = sh(1).Duplicate
                        s.Name = "x": s.Copy: Factive.Paste
                        With Factive.Shapes.Range(Array(s.Name))
                            .Top = item2.Top
                            .Left = item2.Left
                            .Name = sh(1).Name
                        End With
                    ElseIf item1.Column = 15 Then
                        Set s = sh(2).Duplicate
                        s.Name = "x": s.Copy: Factive.Paste
                        With Factive.Shapes.Range(Array(s.Name))
                            .Top = item2.Top
                            .Left = item2.Left + item2.Width - .Width
                            .Name = sh(2).Name
                        End With
                    End If
                End If
         Next item1
        End If
    Next item2
End Sub

Sub testbisNettoyer()
' ********************************************************************
    Dim FGroupSemaine As Worksheet
    Set FGroupSemaine = Worksheets("Groupe semaine")
    Dim Rg1 As Range
    Set Rg1 = Union(FGroupSemaine.Range(FGroupSemaine.Cells(1, 14), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 14).End(xlUp).Row, 14)), FGroupSemaine.Range(FGroupSemaine.Cells(1, 15), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 15).End(xlUp).Row, 15)))
    Dim item1 As Range
    Dim sh(1 To 2) As Shape
    Set sh(1) = FGroupSemaine.Shapes("AutoShape 13")
    Set sh(2) = FGroupSemaine.Shapes("Oval 93")
    ' ********************************************************************
    Dim Factive As Worksheet
    Set Factive = Worksheets(ActiveSheet.Name)
    Dim Rg2 As Range
    Set Rg2 = Union(Factive.Range(Factive.Cells(1, 3), Factive.Cells(Factive.Cells(65536, 3).End(xlUp).Row, 3)), Factive.Range(Factive.Cells(1, 5), Factive.Cells(Factive.Cells(65536, 5).End(xlUp).Row, 5)), Range(Factive.Cells(1, 7), Factive.Cells(Factive.Cells(65536, 7).End(xlUp).Row, 7)))
    ' *******************************************************************
    Dim s As Shape
    For Each s In Factive.Shapes
        If s.Name = sh(1).Name Or s.Name = sh(2).Name Then
            s.Delete
        End If
    Next s
    Dim item2 As Range
    For Each item2 In Rg2
        If item2.Value <> Empty Then
            For Each item1 In Rg1
                If item1.Value = item2.Value Then
                    If item1.Column = 14 Then
                        'With sh(2).Duplicate: .Copy: Factive.Paste: .Delete: Set shap = Selection: End With
                        With sh(1): .Copy: Factive.Paste: Set shap = Selection: End With
                        With shap
                            .Name = 15 & "-" & item2.Row
                            .Top = item2.Top
                            .Left = item2.Left
                        End With
                    ElseIf item1.Column = 15 Then
                        'With sh(2).Duplicate: .Copy: Factive.Paste: .Delete: Set shap = Selection: End With
                        With sh(2): .Copy: Factive.Paste: Set shap = Selection: End With
                        With shap
                            .Name = 15 & "-" & item2.Row
                            .Top = item2.Top
                            .Left = item2.Left + item2.Width - .Width
                        End With
                    End If
                End If
            Next item1
        End If
    Next item2
End Sub

Sub Images()
Dim d As Object, c As Range, s As Shape, mem
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où...
With Feuil2 'CodeName, à adapter
    .DrawingObjects.Placement = 2 'Déplacer sans dimensionner avec les cellules
    For Each c In .UsedRange.SpecialCells(xlCellTypeConstants, 2)
        If d.exists(c.Value) Then
            Set d(c.Value) = .Range("P2") 'doublon, cellule à adapter
        Else
            If c.Column = 14 Then Set d(c.Value) = .Range("N2") 'cellule à adapter
            If c.Column = 15 Then Set d(c.Value) = .Range("O2") 'cellule à adapter
        End If
    Next c
End With
With ActiveSheet
    For Each s In .Shapes
        If s.Name Like "AutoShape*" Or s.Name Like "Oval*" Then s.Delete
    Next s
    For Each c In .UsedRange.SpecialCells(xlCellTypeConstants, 2)
        If d.exists(c.Value) Then
            mem = c
            d(c.Value).Copy c 'copie/colle la cellule avec son objet
            c = mem
        End If
    Next c
End With
End Sub