Problème extraction automatique de donné fonction find

Bonjour,
Je souhaite a partir d'un fichier comprenant divers id, à en extraire seulement certains à partir d'une liste que je copie collerai dans ma colonne 10 (le nombre d'identifiant dans liste pouvant varier)
J'ai donc tenté d'utiliser la fonction .find et d'y associer ensuite la procédure que j'aimerai faire.
Seulement au lieu de copier coller un jour semaine (lundi mardi mercredi jeudi ou vendredi) ET un jour weekend (samedi ou dimanche) s'il trouve une correspondance, il s'arrête au premier copier coller sans chercher d'autre correspondance et surtout sans passer à l'identifiant numéro2 quand il a fini avec le 1
voilà mon code, merci de votre aide

Sub selection()

Dim i As Integer, j As Integer, Lig As Long, nbsemaine As Integer, nbweekend As Integer
Dim sNom As String, criter1 As String
Dim nbre As Integer, Cptr As Long

i = 1
j = 2

Application.ScreenUpdating = False

While Cells(i, 10) <> ""
    criter1 = Cells(i, 10)
    nbre = Application.CountIf(Columns("A"), criter1)
    If nbre = 0 Then
    i = i + 1
    Else
    Lig = ActiveSheet.Columns(1).Find(what:=criter1).Row
        For Cptr = 1 To nbre
            If Cells(Lig, 7) = 1 Then
                If Cells(Lig, 8) = "lundi" And nbsemaine = 0 Then
                    Range(Cells(Lig, 8), Cells(Lig - 23, 1)).Copy
                    Sheets("Feuil1").Select
                    Cells(j, 1).Select
                    ActiveSheet.Paste
                    j = j + 24
                    nbsemaine = nbsemaine + 1
                End If
                If Cells(Lig, 8) = "mardi" And nbsemaine = 0 Then
                    Range(Cells(Lig, 8), Cells(Lig - 23, 1)).Copy
                    Sheets("Feuil1").Select
                    Cells(j, 1).Select
                    ActiveSheet.Paste
                    j = j + 24
                    nbsemaine = nbsemaine + 1
                End If
                If Cells(Lig, 8) = "mercredi" And nbsemaine = 0 Then
                    Range(Cells(Lig, 8), Cells(Lig - 23, 1)).Copy
                    Sheets("Feuil1").Select
                    Cells(j, 1).Select
                    ActiveSheet.Paste
                    j = j + 24
                    nbsemaine = nbsemaine + 1
                End If
                If Cells(Lig, 8) = "jeudi" And nbsemaine = 0 Then
                    Range(Cells(Lig, 8), Cells(Lig - 23, 1)).Copy
                    Sheets("Feuil1").Select
                    Cells(j, 1).Select
                    ActiveSheet.Paste
                    j = j + 24
                    nbsemaine = nbsemaine + 1
                End If
                If Cells(Lig, 8) = "vendredi" And nbsemaine = 0 Then
                    Range(Cells(Lig, 8), Cells(Lig - 23, 1)).Copy
                    Sheets("Feuil1").Select
                    Cells(j, 1).Select
                    ActiveSheet.Paste
                    j = j + 24
                    nbsemaine = nbsemaine + 1
                End If
                If Cells(Lig, 8) = "samedi" And nbweekend = 0 Then
                    Range(Cells(Lig, 8), Cells(Lig - 23, 1)).Copy
                    Sheets("Feuil2").Select
                    Cells(j, 1).Select
                    ActiveSheet.Paste
                    j = j + 24
                    nbweekend = nbweekend + 1
                End If
                If Cells(Lig, 8) = "dimanche" And nbweekend = 0 Then
                    Range(Cells(Lig, 8), Cells(Lig - 23, 1)).Copy
                    Sheets("Feuil2").Select
                    Cells(j, 1).Select
                    ActiveSheet.Paste
                    j = j + 24
                    nbweekend = nbweekend + 1
                End If
            End If
            Lig = Lig + 1
        Next
        i = i + 1
        nbsemaine = 0
        nbweekend = 0
    End If
Application.ScreenUpdating = True
Wend
End Sub