Recherche sur une plage de données

Sub Liste()
Dim lig&, cel As Range, Ident$, Prop As Range, Etiq$, Nom$
Application.ScreenUpdating = False
lig = 2
With Sheets("Liste")
  .[A2:D65536].ClearContents
  For Each cel In ActiveSheet.UsedRange
    If InStr(cel, ".") Then
      Ident = NUM(cel)
      If Ident <> "" And Ident <> cel Then
        Set Prop = Cells.Find(Ident, LookIn:=xlValues, LookAt:=xlWhole)
        If Not Prop Is Nothing Then
          Set Prop = Prop.Offset(, 1)
          Etiq = cel.Offset(-3)
          If Prop <> "" And Etiq <> "" Then
            Nom = cel.Offset(-2)
            If cel.Offset(-2, 3) = "" Then
              Ident = cel
            Else
              Ident = cel & "a"
              .Cells(lig, 1) = Ident
              .Cells(lig, 2) = Prop
              .Cells(lig, 3) = Etiq
              .Cells(lig, 4) = Nom
              lig = lig + 1
              Ident = cel & "b"
              Nom = cel.Offset(-2, 3)
            End If
            .Cells(lig, 1) = Ident
            .Cells(lig, 2) = Prop
            .Cells(lig, 3) = Etiq
            .Cells(lig, 4) = Nom
            lig = lig + 1
          End If
        End If
      End If
    End If
  Next
  'tri sur 3 colonnes
  .[A:D].Sort .[A1], xlAscending, .[B1], , xlAscending, .[C1], xlAscending, xlYes
  .Activate
End With
End Sub

Function NUM$(t)
'renvoie les chiffres et le point
Dim i%
For i = 1 To Len(t)
  If Not IsNumeric(Mid(t, i, 1)) And Mid(t, i, 1) <> "." Then Exit For
Next
If i > 1 Then NUM = Left(t, i - 1)
End Function

Ident = Replace(Val(Replace(Replace(UCase(cel), "D", "#"), "E", "#")), ",", ".")