boucle et condition trop long à executer !!

Sub Test()
dim cellule as range
'selection de la derniere ligne
DerLigDonnees = Worksheets("DONNEES").Range("A65536").End(xlUp).Row
    For e = 2 To DerLigDonnees
        set cellule = nothing
        set cellule = sheets("LIB FAM").range("A:A").Find(sheets("DONNEES").range("O" & e).value lookin:=XlValues)
        if not cellule is nothing then sheets("DONNEES").range("O" & e).value = cellule.offset(0,1)
    Next e
End Sub

Sub RechercheCopiev2()

Dim cellule As Range, recherche As String, e As Long

'selection de la derniere ligne
DerLigFam = Worksheets("LIB FAM").Range("A65536").End(xlUp).Row
    
    For e = 1 To DerLigFam
        Set cellule = Nothing
        valeur = Sheets("LIB FAM").Range("A" & e).Value
        Set cellule = Sheets("DONNEES").Range("F:F").Find(valeur, LookIn:=xlValues)
        If Not cellule Is Nothing Then Sheets("DONNEES").Range("O" & e).Value = cellule.Offset(0, 1)
    Next e
End Sub

    Dim table As Range, i As Long, cellule As Range, mem As Range
    Set table = Sheets("DONNEES").Range("F2:F" & Sheets("DONNEES").Range("A65536").End(xlUp).Row)
    For i = 1 To Sheets("LIB FAM").Range("A65536").End(xlUp).Row
        Set cellule = Nothing
        Set mem = Nothing
        Set cellule = table.Find(Sheets("LIB FAM").Range("A" & i).Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not cellule Is Nothing Then
            Set mem = cellule
            Do
                cellule.Offset(0, 9) = Sheets("LIB FAM").Range("B" & i)
                Set cellule = table.FindNext(after:=cellule)
            Loop While Not cellule Is Nothing And mem.Address <> cellule.Address
        End If
    Next i