Condition sur la première cellule

Pouvez-vous m'aider ?

Sub copieRows()
Application.ScreenUpdating = False
    Dim Fsource As Worksheet
    Dim Fcible As Worksheet
    Dim RngSource As Range
    Dim LasRow As Long
    Dim crit As String
    Dim NumLignAcopier As Long
    
    'Feuille source
    Set Fsource = Sheets("Feuil1")
    
    'Feuille cible
    Set Fcible = Sheets("Feuil2")
    
    'Critère de comparaison
    crit = "83654"
    
    ' On défini la plage contenant les cellules à traiter
    Set RngSource = Range("A1:A2000")
    
    'On boucle sur les cellules..
    For Each cell In RngSource
     valCel = cell.Value
     If valCel = crit Then
        NumLignAcopier = cell.Row
        
        'Copie de la ligne:
        Rows(NumLignAcopier).Select
        Selection.Copy
        
        'On se place dans la feuille Cible
        Fcible.Activate
        'On trouve la dernière ligne non vide + 1
        LastRow = Derniere_Ligne(Fcible.Name)
        'On colle la ligne
        Cells(LastRow, 1).Select
        ActiveSheet.Paste
        'On se remet dans la feuille 1
         Fsource.Activate
     End If
    Next
Application.ScreenUpdating = True
End Sub


Function Derniere_Ligne(Nom_Feuille As String) As Long
 Sheets(Nom_Feuille).Activate
 Derniere_Ligne = Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row + 1 'pour les lignes
End Function

Option Explicit
Const valeur As Long = 83654
'---
Sub copier_si()
Dim Derlig As Integer, Dercol As Integer, Nbre As Integer
Dim T_in, T_out, Idx_in As Integer, Idx_out As Integer, Col As Integer
Dim start As Single

    'initialisations
    start = Timer
    Application.ScreenUpdating = False
    With Sheets(1)
        Dercol = .Rows(1).Find("*", , , , , xlPrevious).Column
        Derlig = .Columns("A").Find(valeur, , , , , xlPrevious).Row
        Nbre = Application.CountIf(.Columns("A"), valeur)
        T_in = Range(.Cells(1, "A"), .Cells(Derlig, Dercol))
        ReDim T_out(1 To Nbre, 1 To Dercol)
    End With
    
    'Recherche lignes avec valeur
    For Idx_in = 1 To UBound(T_in)
        If T_in(Idx_in, 1) = valeur Then
            Idx_out = Idx_out + 1
            For Col = 1 To Dercol
                T_out(Idx_out, Col) = T_in(Idx_in, Col)
            Next
        End If
    Next
    'restitution
    Sheets(2).Range("A1").Resize(Nbre, Dercol) = T_out
    Application.ScreenUpdating = True
    MsgBox "durée: " & Timer - start & " sec."

End Sub