Microsoft 365 Déplacer cellules en gardant mise en forme source et cible (via VBA)

Sub Transfert()
Dim c As Range
ActiveCell.Activate 'au cas où Selection n'est pas un Range
For Each c In Selection
    If Not Intersect(c, [J:M], ActiveSheet.UsedRange) Is Nothing And Not Cells(c.Row, 10).Validation Is Nothing Then c(1, -6) = c
Next
End Sub

Sub Transfert()
Dim r As Range
ActiveCell.Activate 'au cas où Selection n'est pas un Range
Set r = Intersect(Selection, [J:M], ActiveSheet.UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r 'si sélection multiple
    If Not Cells(r.Row, 10).Validation Is Nothing Then r(1, -6) = r
Next
End Sub

Sub SelectCF()
'se lance par le raccourci Ctrl+C
Dim r As Range, lig&, decal&, dest As Range
ActiveCell.Activate 'au cas où Selection n'est pas un Range
Set r = Intersect(Selection, [C:F], ActiveSheet.UsedRange)
If r Is Nothing Then Exit Sub
lig = Abs(Int(Val(InputBox("Numéro de ligne du collage :"))))
If lig = 0 Then Exit Sub
decal = lig - Selection(1).Row
For Each r In r 'si sélection multiple
    Set dest = r(1, 8).Offset(decal)
    If Not Cells(r.Row, 3).Validation Is Nothing And Not Cells(dest.Row, 10).Validation Is Nothing Then dest = r
Next
End Sub

Sub SelectJM()
'se lance par le raccourci Ctrl+J
Dim r As Range, lig&, decal&, dest As Range
ActiveCell.Activate 'au cas où Selection n'est pas un Range
Set r = Intersect(Selection, [J:M], ActiveSheet.UsedRange)
If r Is Nothing Then Exit Sub
lig = Abs(Int(Val(InputBox("Numéro de ligne du collage :"))))
If lig = 0 Then Exit Sub
decal = lig - Selection(1).Row
For Each r In r 'si sélection multiple
    Set dest = r(1, -6).Offset(decal)
    If Not Cells(r.Row, 10).Validation Is Nothing And Not Cells(dest.Row, 3).Validation Is Nothing Then dest = r
Next

dest = r

dest = r: r = ""