Copier sous condition une ligne en en créant de nouvelles

Je cherche à copier des cellules selon une condition mais il faudra créer des lignes au passage.

En feuil1 j'ai en colonne A des données différentes mais qui se répètent plusieurs fois. En colonne B j'ai d'autres données mais qui sont uniques.

Je veux copier dans la feuil2 les données de la colonne B selon les données de la colonne A. J'ai essayé avec rechercheV mais comme les données de la colonne A se répètent et qu'il me faut à chaque fois les infos de la colonne B correspondantes, je cherche un moyen de créer des lignes.

Exemple :

Feuil1 mes données

colonne A colonne B

code noms

1 xxxxx

3 yyyyy

3 ttttttt

2 oooo

1 bbbb

2 ccccc

En feuil2 je souhaite avoir au final

colonne 1 colonne B

code noms

1 xxxx

1 bbbb

En feuil3 j'aurais les codes 2, en feuil4 les code 3, etc

Merci de vos conseils.

Bonjour et bienvenue,

Merci de joindre un fichier à ta demande.

Cdlt.

Voici le fichier test.

Merci

Bonjour

Voir fichier

Cordialement

Bonjour à tous,

Avec un dictionnaire :

Option Explicit

Sub test()
Dim dico As Object, i As Long, e
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("a1").CurrentRegion
        For i = 2 To .Rows.Count
            If .Cells(i, 1).Value <> "" Then
                If Not dico.exists(.Cells(i, 1).Value) Then
                    Set dico(.Cells(i, 1).Value) = .Rows(1)
                End If
                Set dico(.Cells(i, 1).Value) = _
                Union(dico(.Cells(i, 1).Value), .Rows(i))
            End If
        Next
    End With
    For Each e In dico.keys
        If Not IsSheetExists(CStr(e)) Then
            Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
        End If
        With Sheets(CStr(e)).Cells(1)
            .CurrentRegion.Clear
            dico(e).Copy .Cells(1)
        End With
    Next
    Application.ScreenUpdating = True
End Sub

Function IsSheetExists(ByVal feuille As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(feuille).Name)
End Function

klin89

Bonjour,

Un 3ème proposition.

Cdlt.

C'est génial merci