Concatener + selection + doublons

bonjour je me présente SAM et une grosse migraine loll

je reviens vers vous vu divers résultat sur le sujet concaténer et autres !

mon problème est le suivant j'ai dans la colonne A mes références qui parfois sont identiques (donc le critère ) et dans la colonne D des couleurs d'articles qui parfois sont identiques ( le piégeeeeeeeeee lol )

j'aimerais si possible pourvoir avoir en colonne F par exemple l'ensemble des couleurs sur une même ligne et sans les doublons.

voila voila !!!

je vous remercie d'avance d'avoir pris le temps de lire mon message. dans l'attente de pouvoir vous lire

cordialement

Bonjour,

Que dirais-tu d'une solution en 10 secondes ...

Bonsoir Sam, James, bonsoir le forum,

Une autre solution avec le code ci-dessous très rapide aussi :

Sub Macro4()
Dim O As Object 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (Plage)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)
Dim TCV As Variant 'déclare la variable TCV (Tableau des Celules Visibles)
Dim CO() As String 'déclare la variable CO (tableau des COuleurs)
Dim COU As String 'déclare la variable COU (COUleurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Sheets("Feuil1") 'définit l'onglet O
DL = O.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 1 (=A) de l'onglet O
Set PL = O.Range("A2:F" & DL) 'définit la plage PL
TC = PL 'définit le tableau de cellules TC
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 1 To UBound(TC, 1) 'boucle : sur toutes les lignes du tableau TC
    D(TC(I, 1)) = "" 'alimente le dictionnaire avec la valeur en colonne 1 de chaque ligne tableau TC
Next I 'prochaine ligne de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP les éléments du dictionnaire D sans doublon
For I = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau TMP
    Erase CO 'efface le tableau de couleurs CO
    O.Range("A1").AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre en A1 la colonne 1 (=A) de l'onglet O avec TMP(I) comme critère
    Set PLV = PL.SpecialCells(xlCellTypeVisible) 'définit la plage PLV (cellules visibles (non filtrées) de la plage PL)
    TCV = PLV 'définit le tableau de cellules visibles TCV
    ReDim CO(0) 'redimensionne le tableau de couleur CO
    CO(0) = "": COUL = "" 'initialise le tableau de couleurs CO et le texte des couleurs COUL
    For J = 1 To UBound(TCV, 1) 'boucle 2 : sur toutes les lignes du tableau TCV (les ligne visibles)
        If UBound(CO) = 0 And CO(0) = "" Then 'condition : si le tableau CO ne contient qu'un seul élément et si cet élément est vide
            CO(0) = TCV(J, 4) 'récupère la premère couleur de la première ligne visible
        Else 'sinon
            For K = 0 To UBound(CO) 'boucle 3 : sur toutes les couleurs du tableau de couleurs CO
                'si la couleur de l'élement visible existe déjà dans le tableau de couleurs, va à l'étiquette "suite"
                If TCV(J, 4) = CO(K) Then GoTo suite
            Next K 'prochaine couleur de la boucle 3
            ReDim Preserve CO(UBound(CO) + 1) 'redimensionne le tableau de couleur
            CO(UBound(CO)) = TCV(J, 4) 'ajoute la couleur de l'élément visible au tableau de couleurs CO
        End If 'fin de la condition
suite: 'étiquette
    Next J 'prochaine ligne de la boucle 2
    'à ce stade le tableau de couleur CO est plein...
    For L = 0 To UBound(CO) 'boucle 4 : sur toutes les couleurs du tableau de couleurs CO
        COUL = IIf(COUL = "", CO(L), COUL & ", " & CO(L)) 'définit le texte des couleurs COUL
    Next L 'prochaine couleurs de la boucle 4
    For J = 1 To UBound(TCV, 1) 'boucle 5 : sur toutes les lignes du tableau TCV (les ligne visibles)
        PLV.Cells(J, 6) = COUL 'place le texte COUL dans la cellule en colonne F
    Next J 'prochaine ligne de la boucle 5
    O.Range("A1").AutoFilter 'supprime le filtre automatique
Next I 'prochain élément de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

bonjour,

et merci je vais regarder cela demain si cela fonctionne ben j'ai la honte car moi en 10h voir 10j j'ai pas réussi

et j'ai toujours ma migraine loll

sam62 a écrit :

bonjour,

et merci je vais regarder cela demain si cela fonctionne ben j'ai la honte car moi en 10h voir 10j j'ai pas réussi

et j'ai toujours ma migraine loll

Pour éviter les fortes migraines ... viens sur le Forum ...

Tu auras un gain de temps ... et une économie sur l'aspirine ...

Edit: salut ThauThème ... ta macro prend plus de 10 secondes ... pas à éxécuter ... mais à taper ...

qui a dit que macro c'était pas un boulot !!!

bon oki je sors !!!

Bonjour Sam

Très largement hors sujet : J'adore vraiment ton avatar ... ...

Peux-tu me dire où tu l'as pêché ... Merci ...

bonjour,

oui tout simplement sur le site dans avatar et tout en bas de page lol

Bonjour le fil, bonjour le forum,

Heu... Sinon Sam, la macro, ça va ?

@James, Ho oui plus de 10 minutes à taper et surtout plus d'une heure à cogiter...

bonjour,

Alors oui la solution de James fonctionne également celle de Frangy sur un autre post aussi

mais la j'essais de comprendre pour l'appliquer sur d'autres feuilles

j'ai comprisssssssss nikel encore merci à tous

Rhooooo la morale de l'histoire c'est que le monde change pas vraiment ! hein ! quand tu as un coup de P**te avec un fichier qui te t'embête rien de tel qu'un(e) Macro pour régler le problème et donc il faut reconnaitre qu'il "Excel" au final

Bonnn oki je sors !!!!!

Avatar de l’utilisateur