Microsoft 365 Copier coller les mêmes valeurs dans la même cellule

Sub CopierColler()
    T = [I21:I27]
    Range(ActiveCell.Address).Resize(7, 1).Value = T
    [I21:I27].ClearContents
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Dim a, i&
a = [memo]
If IsArray(a) Then
    For i = 1 To UBound(a)
        Range(a(i, 1)) = a(i, 2)
    Next i
    ThisWorkbook.Names("memo").Delete
Else
    Set Target = Intersect(Target, UsedRange)
    If Target Is Nothing Then Exit Sub
    ReDim a(1 To Target.Count, 1 To 2)
    For Each Target In Target
        i = i + 1
        a(i, 1) = Target.Address
        a(i, 2) = Target
        Target = ""
    Next Target
    ThisWorkbook.Names.Add "memo", a
End If
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Set Target = [I21,I23,I25,I27] 'plage à étudier, modifiable
Dim a, i&
a = [memo]
If IsArray(a) Then
    For i = 1 To UBound(a)
        Range(a(i, 1)) = a(i, 2)
    Next i
    ThisWorkbook.Names("memo").Delete
Else
    ReDim a(1 To Target.Count, 1 To 2)
    For Each Target In Target
        i = i + 1
        a(i, 1) = Target.Address
        a(i, 2) = Target
        Target = ""
    Next Target
    ThisWorkbook.Names.Add "memo", a
End If
End Sub

Sub Couper_Ccller()
Dim c As Range
With Sheets("Feuil2").[I21,I23,I25,I27]
    If Application.CountA(.Cells) Then
        For Each c In .Cells
            c.Copy c(1, 4): c.Clear
        Next c
    Else
        For Each c In .Cells
            c(1, 4).Copy c: c(1, 4).Clear
        Next c
    End If
End With
End Sub