For to next incrémenté dans find next

Bonjour à tous!
Je vous rejoins pour obtenir de l'aide sur mon code vba

Dans ma feuille AA, j'ai un code find qui doit rechercher toutes les valeurs de ma base dont la colonne I contient "Croix rouge"
Le code find et Find next fonctionne très bien.
Le problème survient après le do car for to next devrait recopier les lignes contenant "croix rouge" les unes après les autres sauf qu'il les recopie toutes sur la même ligne et à la fin ne garde que la dernière ligne contenant "croix rouge"

Voici le code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub Recherche()
 
    Dim Dlinge
    Dim x As Long
    Dim CR As Range
    Dim First As String
 
        dligne = Worksheets("Base").Range("A" & Rows.Count).End(xlUp).Row
 
        With Worksheets("Base").Range("I1:I" & dligne)
        Set CR = .Find("Croix rouge", LookIn:=xlValues)
        If Not CR Is Nothing Then
            First = CR.Address
        Do
                x = 7
                For i = 1 To dligne
                If Worksheets("Base").Range("I" & i).Value = CR Then
                Worksheets("AA").Range("A" & x & ":K" & x).Value = Worksheets("Base").Range("A" & i & ":K" & i).Value
                Worksheets("AA").Range("P" & x & ":T" & x).Value = Worksheets("Base").Range("N" & i & ":R" & i).Value
                 x = x + 1
                End If
                Next i
            Set CR = .FindNext(CR)
        Loop While Not CR Is Nothing And CR.Address <> First
        End If
    End With
 
End Sub

Merci pour votre aide!

Bonjour,

Essayez ceci:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub Recherche()
    Dim Dlinge
    Dim x As Long
    Dim CR As Range
    Dim First As String
    Application.ScreenUpdating = False
    dligne = Worksheets("Base").Range("A" & Rows.Count).End(xlUp).Row
    x = 7
    With Worksheets("Base").Range("I1:I" & dligne)
        Set CR = .Find("Croix rouge", LookIn:=xlValues)
        If Not CR Is Nothing Then
            First = CR.Address
            Do
                Worksheets("AA").Range("A" & x & ":K" & x).Value = Worksheets("Base").Range("A" & CR.Row & ":K" & CR.Row).Value
                Worksheets("AA").Range("P" & x & ":T" & x).Value = Worksheets("Base").Range("N" & CR.Row & ":R" & CR.Row).Value
                x = x + 1
                Set CR = .FindNext(CR)
            Loop While Not CR Is Nothing And CR.Address <> First
        End If
    End With
End Sub

Cdlt

merci beaucoup