Déplacement de cellule

Private Sub Worksheet_BeforeDoubleClick(ByVal Cible As Range, Contremander As Boolean)
Dim i&, liO&, coO&, coD&, CO As Range, CRef As Range, MRef As Range, Echo As Range

    Set CRef = Range("C5:Z74")          'Plage de données. À adapter !

1:  Set Echo = Range("AF5")             'Début de la plage d'"écho".

    Set CO = Cible(1)
    If Not Intersect(CO, CRef) Is Nothing Then
        If Not IsEmpty(CO.Value) Then
            Set MRef = CRef(CRef.Count)
            liO = CO.Row
            If Not IsEmpty(Cells(liO + 1, MRef.Column)) Then MsgBox "Plus de place !": Exit Sub
            coO = CO.Column
            coD = WorksheetFunction.Max(Cells(liO + 1, MRef.Column + 1).End(xlToLeft).Column + 1, CRef(1).Column)
            For i = coO + 1 To MRef.Column
                If IsEmpty(Cells(liO, i)) Then Exit For
            Next
            On Error GoTo E
            With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
            CO.Cut Destination:=Cells(liO + 1, coD)

2:          Cells(liO, coO).Offset(Echo.Row - CRef(1).Row, Echo.Column - CRef(1).Column).Value = "X"

            If i > coO + 1 Then
                Cells(liO, coO + 1).Resize(, MRef.Column - coO).Copy Destination:=Cells(liO, coO)
                coO = MRef.Column
            End If
            MRef.Copy Destination:=Cells(liO, coO)
R:          With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
        End If
    End If
Exit Sub
E:
    MsgBox "Erreur imprévue !"
    Resume R
End Sub