Problème sélection

Bonjour, j'ai ce code qui fonctionne si je ne sélectionne qu'une seule cellule mais je voudrais l'adapter à une sélection de cellule, auriez-vous une idée ? Merci. Ci-joint le fichier.

Dim NoLigne, NoColonne, DerLigne As Integer

    Dim FD As Worksheet

    NoLigne = ActiveCell.Row
    NoColonne = ActiveCell.Column
    DerLigne = Sheets("Données").Range("A" & Rows.Count).End(xlUp).Row + 1
    DerLigne2 = Sheets("SAVE").Range("A" & Rows.Count).End(xlUp).Row + 1
    DerLigne3 = Sheets("Planning").Range("E" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False
    If Not Application.Intersect(ActiveCell, Range("F8:Y" & DerLigne3)) Is Nothing Then
        Set FD = Worksheets("Données")
        Set SA = Worksheets("SAVE")
                FD.Range("B" & DerLigne).Value = Cells(NoLigne, 5).Value
                SA.Range("B" & DerLigne2).Value = Cells(NoLigne, 5).Value
                FD.Range("C" & DerLigne).Value = Cells(6, NoColonne).Value
                SA.Range("C" & DerLigne2).Value = Cells(6, NoColonne).Value
                FD.Range("D" & DerLigne).Value = "PO"
                SA.Range("D" & DerLigne2).Value = "PO"
                FD.Range("E" & DerLigne).Value = Now()
                SA.Range("E" & DerLigne2).Value = Now()
    End If

Dim i As Long, j As Long

    For i = Sheets("Données").Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        For j = Sheets("Données").Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            If Sheets("Données").Cells(j, 1) = Sheets("Données").Cells(i, 1) Then
            If Sheets("Données").Cells(j, 5) < Sheets("Données").Cells(i, 5) Then
                Sheets("Données").Cells(j, 1).EntireRow.Delete
                End If: End If
                Next j: Next i
                 For i = Sheets("SAVE").Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
                For j = Sheets("SAVE").Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
                If Sheets("SAVE").Cells(j, 1) = Sheets("SAVE").Cells(i, 1) Then
                If Sheets("SAVE").Cells(j, 5) < Sheets("SAVE").Cells(i, 5) Then
                Sheets("SAVE").Cells(j, 1).EntireRow.Delete
            End If: End If
    Next j: Next i

Application.ScreenUpdating = True
End Sub

J'ai réussi en ajoutant ceci

u = selection.Address
   For Each cel In Range(u)
    NoLigne = cel.Row
    NoColonne = cel.Column