Exporter des données d'une feuille à une autre selon une condition

Bonjour,

Je découvre ce forum et remercie déjà tous ceux qui le font vivre. Malheureusement je n'ai pas trouvé de solution à mon problème et espère poster au bon endroit.

Voilà donc ma question:

Sur ma première feuille j'ai un tableau que je remplis manuellement (dont une colonne comportant une liste déroulante). J'ai pris un exemple simple que vous trouverez ci-joint: une liste d'objets et pour chaque objet une couleur correspondante (ex: bateau rouge, chaise jaune, porte rouge, etc.). Je souhaiterais savoir s'il est possible de lister sous une autre feuille tous les objets correspondant à une couleur donnée. Concrètement, une feuille "rouge" sous laquelle apparaîtrait une liste de tous les objets rouges (bateau, porte, …). J'ai essayé plusieurs options mais rien de concluant, la solution dépassant mes compétences en la matière.

Merci à ceux qui s'intéresseront à cette question et bonne journée à tous.

Bonjour :)

Je suis en train de travailler sur ton sujet, j'ai une question, sur les feuilles de couleur, à part l'importation des objets y a -t-il d'autres données présentes ? Et dans quelle colonne veux tu importer les objets ?

Voilà un fichier test pour déjà avoir un aperçu :)

Sub Creation()
Dim FEUILLE As Worksheet, FEUILLE_EXP As Worksheet
Dim PLAGE As Range
Dim TBL(), TBL_TEST()
Dim COULEUR As String, TEST_COULEUR As String
Dim AJOUT As Boolean
Dim DERNLIG As Long

Set FEUILLE = ThisWorkbook.Worksheets("Données")
Set PLAGE = FEUILLE.UsedRange
TBL = PLAGE.Offset(1, 0).Resize(PLAGE.Rows.Count - 1, PLAGE.Columns.Count)

'Création des feuilles
With ThisWorkbook
    For i = 1 To UBound(TBL, 1)
        AJOUT = True
        COULEUR = TBL(i, 2)
        For j = 1 To .Worksheets.Count
            TEST_COULEUR = .Worksheets(j).Name
            If COULEUR = TEST_COULEUR Then AJOUT = False: Exit For
        Next j
        If AJOUT = True Then .Sheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = COULEUR
    Next i
End With

'Ajout des données sur les feuilles correspondentes
For i = 1 To UBound(TBL, 1)
    Set FEUILLE_EXP = ThisWorkbook.Worksheets(TBL(i, 2))
    DERNLIG = FEUILLE_EXP.Range("A" & FEUILLE_EXP.Rows.Count).End(xlUp).Row + 1
    TBL_TEST = FEUILLE_EXP.Range("A1:A" & DERNLIG)
    AJOUT = True
    For j = 1 To UBound(TBL_TEST)
        If TBL_TEST(j, 1) = TBL(i, 1) Then AJOUT = False: Exit For
    Next j
    If AJOUT = True Then FEUILLE_EXP.Range("A" & DERNLIG) = TBL(i, 1)
Next i

FEUILLE.Activate
End Sub

Bonjour,

Merci pour le temps pris sur ce sujet! Il pourrait en effet y avoir d'autres données par la suite (autres colonnes sans interaction). Pour la 2ème question, si on reprend l'exemple donné, ce serait de voir les objets rouges être copiés dans la colonne B de la feuille "rouge".

Ok alors voilà un ajustement :

Option Explicit
Sub Creation()
Dim FEUILLE As Worksheet, FEUILLE_EXP As Worksheet
Dim PREMLIG As Long, PREMCOL As String, DERNCOL As String, DERNLIG As Long
Dim PLAGE As Range
Dim TBL(), TBL_TEST()
Dim COULEUR As String, TEST_COULEUR As String
Dim AJOUT As Boolean
Dim i As Long, j As Long

Set FEUILLE = ThisWorkbook.Worksheets("Données")

'Dimentionnement de la BD avec entêtes
PREMLIG = 1 'A ajuster
PREMCOL = "A" 'A ajuster
DERNCOL = "B" 'A ajuster

DERNLIG = FEUILLE.Range(PREMCOL & FEUILLE.Rows.Count).End(xlUp).Row
Set PLAGE = FEUILLE.Range(PREMCOL & PREMLIG & ":" & DERNCOL & DERNLIG)
TBL = PLAGE.Offset(1, 0).Resize(PLAGE.Rows.Count - 1, PLAGE.Columns.Count)

'Création des feuilles
With ThisWorkbook
    For i = 1 To UBound(TBL, 1)
        AJOUT = True
        COULEUR = TBL(i, 2)
        For j = 1 To .Worksheets.Count
            TEST_COULEUR = .Worksheets(j).Name
            If COULEUR = TEST_COULEUR Then AJOUT = False: Exit For
        Next j
        If AJOUT = True Then .Sheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = COULEUR
    Next i
End With

'Ajout des données sur les feuilles correspondentes
For i = 1 To UBound(TBL, 1)
    Set FEUILLE_EXP = ThisWorkbook.Worksheets(TBL(i, 2))
    DERNLIG = FEUILLE_EXP.Range("B" & FEUILLE_EXP.Rows.Count).End(xlUp).Row + 1
    TBL_TEST = FEUILLE_EXP.Range("B1:B" & DERNLIG)
    AJOUT = True
    For j = 1 To UBound(TBL_TEST)
        If TBL_TEST(j, 1) = TBL(i, 1) Then AJOUT = False: Exit For
    Next j
    If AJOUT = True Then FEUILLE_EXP.Range("B" & DERNLIG) = TBL(i, 1)
Next i

FEUILLE.Activate
End Sub

Bonjour, je viens aux nouvelles, as tu testé le code ?