Copier coller rows VBA copie les mêmes lignes plusieurs fois au lieu d'une

Bonjour et excellente nouvelle année à vous,

Je voulais que mon code identifie des lignes avec une certaine chaine de caractères dans la première cellule, les copie et les colle dans une autre feuille.

Il le fait mais me copie plein de fois la première ligne d'affilée horizontalement, pareil pour la deuxième ligne et ainsi de suite, ce n'est pas très dérangeant à part que ça m'oblige à venir resélectionner manuellement les colonnes.

Quelqu'un aurait-il une idée de ce qu'il se passe?

Voici mon code:

Sub ctrlcctrlv()

IndexL2 = 1 'index pour coller les lignes les unes après les autres
Index1 = 2 'index de la feuille dont je veux copier des lignes
Index2 = 3 'index de la feuille où je veux coller les lignes
anomalie = "TTT" 'chaine de caractères que je recherche

Worksheets(Index1).Activate
Dim table As Range
Set table = Range(("A7"), Range("A7").End(xlToRight).End(xlDown))
table.Select

For Each rw In table.Rows
    libellé = rw.Cells(1, 1)
    If InStr(1, libellé, anomalie) <> 0 Then
        rw.Copy Worksheets(Index2).Rows(IndexL2)
        IndexL2 = IndexL2 + 1
    End If
Next

End Sub

Bien cordialement,

Rebonjour Jeanne,

Voici le VBA qui copie cette fois :

Sub ctrlcctrlv()
'*****************************************************************************************************************************
' Procédure pour copier les lignes contenant TTT de l'onglet 2 vers l'onglet 3
'*****************************************************************************************************************************
Dim indexL2 As Integer
Dim Index1 As Integer
Dim Index2 As Integer
Dim anomalie As String
Dim libellé As String
Dim i As Integer
Dim lastrow As Integer

indexL2 = 2 'index pour coller les lignes les unes après les autres
Index1 = 2 'index de la feuille dont je veux copier des lignes
Index2 = 3 'index de la feuille où je veux coller les lignes
anomalie = "TTT" 'chaine de caractères que je recherche

Worksheets(Index1).Activate
lastrow = Cells(Worksheets(Index1).Rows.Count, 1).End(xlUp).Row 'Dernière ligne avec des caractères en colonne A
For i = lastrow To 7 Step -1
libellé = Cells(i, 1)
If InStr(1, libellé, anomalie) <> 0 Then
Worksheets(Index1).Cells(i, 1).Copy Worksheets(Index2).Cells(indexL2, 1)
indexL2 = indexL2 + 1
End If
Next

End Sub

Je te joins également mon classeur test qui contient les 2 deux VBA (copier et suppression dont j'ai améliorer le contenu pour calculer le nombre de lignes)

Bonne continuation

Chris