Si nombre d'occurence >1 alors concatener autre colonne

Bonjour,

J'ai parcourus l'aide d'excel et plusieurs forum en vain, alors je vous appelle à l'aide!

J'ai une colonne A avec des référence de produits. Une colonne B avec des codes vehicules qui correspondent aux produits.

Je cherche un moyen de regrouper les mêmes références produit en créant en associant à une référence une cellule qui contiendrait la concaténation des codes véhicules.

Un exemple pour éclaircir mon pb:

une ref 123456 en col apparrait 4 fois en col A

En filtrant avec notre reference col A, voila ce que l'on peut obtenir:

A B

123456 NJ

123456 UI

123456 NJ

123456 XS

Je voudrais un tableau avec comme premiere ligne: col C:123456 et col D: NJ/UI/XS

Est-ce que quelqu'un aurait une idée ou une piste pour m'aider dans ma quête?

Merci d'avance!

Bonjour et bienvenue sur le forum naz4,

Oui c'est possible mais avec un fichier, l'aide apportée serait plus facile. Si besoin, change tes données.

Voila, je t'ai envoyé le fichier simplifié, dans la troisième colonne, c'est ce que j'ai commencer à faire (compter le nombre d'occurence).

Merci d'avance!

-- 20 Juil 2010, 15:37 --

Je me permets de réctifier quelquechose, dans mon premier message j'ai dis ke je cherchais faire un tableau à part mais en réalité je préferais que la concaténation des codes véhicules se fasse à coté de chaque référence produit.

Je ne sais pas si je me suis bien exprimée...

Merci encore!

naz4 a écrit :

Je me permets de réctifier quelquechose, dans mon premier message j'ai dis ke je cherchais faire un tableau à part mais en réalité je préferais que la concaténation des codes véhicules se fasse à coté de chaque référence produit.

Je ne sais pas si je me suis bien exprimée...

Voila le fichier avec en dernière colonne ce que je voudrais obtenir.

Bonjour

J'ai regardé le fichier, mais je n'arrive pas à comprendre la logique du raisonnement amenant au résultat tel qu'il est présenté.

d'autant que j'ai des 60 en plus des 61 et 62

Cordialement

Bonsoir à tous,

çà ne serait pas plutôt ce genre de résultat que tu cherche à obtenir ?

dans la même cellule

6153774 - BK/61/62

Dans ton exemple, le filtre embrouille + qu'autre chose !

Amicalement

Claude

Bonsoir à tous,

Pffiouu ! J'ai galéré !

Regarde dans le fichier joint. J'ai adapté plusieurs codes de Boisgontier. J'ai enlevé le filtrage des lignes. Chez moi le traitement des 7000 et quelques lignes prend un peu moins de 30 secondes.

Salut le forum

Beau travail Vbanew

Mytå

Salut Mytå,

Merci à toi ! Mais il faut relativiser, le code principal n'est pas de moi

La difficulté que j'ai rencontrée a été d'éviter les doublons lors de la concaténation des codes véhicules !

Je pense qu'il y un moyen plus rapide que ce que j'ai fait car je passe par la création d'une feuille temporaire.

Très utiles ces Scripting.Dictionary...

C'est génial ce que tu as réussi à faire vbanew!! Je te remercie énormément (et dire que j'avais perdu tt espoir!)

J'aurai cependant une petite question, qu'est ce que c'est qu'un code boisgontier? Ou peux tu me dire de quoi t'es tu inspiré? J'aimerais en fait comprendre un peu le code et comme je suis une vraie débutante en VBA, je ne sais pas très bien comment l'adapter à mon fichier.

Merci encore et bravo!

Salut naz4,

Jacques boisgontier est vbaïste très compétent ! Une petite recherche sur google et tu tomberas direct sur son site.

Par contre :

naz4 a écrit :

J'aimerais en fait comprendre un peu le code et comme je suis une vraie débutante en VBA, je ne sais pas très bien comment l'adapter à mon fichier.

Merci bien vbanew!

En effet, j'ai fait des petites recherches sur Boisgontier.

J'ai déja fait de la programation avec d'autres que vba donc je reconnais quelques trucs dans le code mais c'est surtout pour l'adapter que j'ai du mal.

Ouf ! J'ai fini les explications. Regarde dans le code suivant. J'espère que ça t'aidera :

Sub renvoi()
'Déclaration des variables
Dim mondico As Object
Dim ShtPrincipal As Worksheet, ShtTemp As Worksheet
Dim i As Long, derlign As Long, derlign2 As Long, cpt As Long
Dim c As Range
Dim a, b

    Application.ScreenUpdating = False
    Set ShtPrincipal = Sheets("Feuil1")    'la feuille sur laquelle se trouve les références et les codes véhicules
    ShtPrincipal.Copy Before:=ShtPrincipal    'ici on fait une copie de la feuille ci-dessus. elle sera placée juste avant la feuille "Feuil1"
    Set ShtTemp = ActiveSheet    'la feuille que l'on vient de copier ne sera que temporaire

    'ici on utilise la méthode du "Dictionary" pour avoir une liste sans doublons des références ET codes véhicules.
    'dans cette méthode, on a (au moins) 2 notions importantes : la clé (Keys) et la valeur correspondante (appelée Item) à cette clé
    'dans notre cas, la référence produit est la clé et le code véhicule = Item
    'cette syntaxe est toujours la même. Tu peux modifier "mondico" par une autre variable si tu veux.
    Set mondico = CreateObject("Scripting.Dictionary")

    i = 2
    derlign = [a65536].End(xlUp).Row    'on cherche le numéro de la dernière ligne de la feuille active
    Do While cpt < derlign    'on entre dans une boucle "Do" et on en sort pas tant que cpt < derlign
        cpt = cpt + 1
        If Not IsError(Cells(i, "A")) Then    'j'ai rajouté cette ligne car dans certaines cellules en colonne A on a #VALEUR!
            If Not mondico.Exists(Cells(i, "A") & "-" & Cells(i, "B")) Then    'si la référence & "-" & le code véhicule n'existe pas dans le dictionnaire
                mondico.Add Cells(i, "A") & "-" & Cells(i, "B"), 1    'on l'ajoute et la valeur correspondante est 1 (dans ce cas là, le 1 n'a pas d'importance, tu peux mettre ce que tu veux)
                i = i + 1
            Else
                Rows(i).EntireRow.Delete    'si la référence ET le code véhicule existe déjà, on supprime la ligne
            End If
        Else
            Rows(i).EntireRow.Delete    'ici on supprime la ligne i si on a #VALEUR! en colonne A ligne i
        End If
    Loop

    'maintenant qu'on a une liste sans doublons des références ET codes véhicules on peut commencer la concaténation
    'ceete fois-ci, on crée un Dictionnaire pour la concaténation des codes véhicules
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In Range("a2:a" & derlign)    'pour chaque cellule dans "a2:a" & dernière ligne
        If Not mondico.Exists(c.Value) Then    'si la réf n'existe pas
            mondico(c.Value) = c.Offset(0, 1) & "/"    'on met un "/" après le code véhicule correspondant à la référence
        Else
            'si la référence existe, on prend le code véhicule correspondant existant déjà
            'et on lui "concatène" à la suite, le nouveau code véhicule avec un "/" à la suite
            mondico(c.Value) = mondico(c.Value) & c.Offset(0, 1) & "/"
        End If
    Next c

    'ensuite on commence l'affichage du résultat
    a = mondico.keys    'on affecte le tableau des clés à la variable a
    b = mondico.items    'on affecte le tableau des éléments associés aux clés à la variable b
    With ShtPrincipal    'Sur la feuille ShtPrincipal déclarée au début
        For i = LBound(b) To UBound(b)    'pour i allant du premier élément de b au dernier

            'on affecte les valeurs dans la colonne 255 (colonne IU) et 256 (colonne IV). c'est pour être sûr qu'il n'y a pas de données
            .Cells(i + 2, 255) = a(i)
            .Cells(i + 2, 256) = Mid(b(i), 1, Len(b(i)) - 1)    'ici on utilise la fonction Mid pour enlever le dernier "/" des codes véhicules concaténés
        Next i
    End With

    'là, on va affecter à chaque référence produit la concaténation des codes véhicules correspondante par une méthode de recherche (méthode Find)
    Application.DisplayAlerts = False    'cette ligne permet ici de ne pas afficher de message lors de la suppression d'une feuille de calcul
    ShtTemp.Delete    'on supprime la feuille temporaire
    derlign = [a65536].End(xlUp).Row
    derlign2 = [iu65536].End(xlUp).Row
    For i = 2 To derlign
        If Not IsError(Cells(i, 1)) Then    'pareil qu'un peu plus haut, j'ai rajouté cette ligne car dans certaines cellules en colonne A on a #VALEUR!

            'on cherche dans la plage "iu2:iu" & derlign2, chaque valeur de la colonne A (Cells(i, 1))
            Set c = Range("iu2:iu" & derlign2).Find(Cells(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
        End If

        'si on trouve la valeur, on affecte à la colonne C (Cells(i, 3)) la valeur de c.Offset(, 1), c'est-à-dire la valeur située une colonne
        'à droite de la colonne IU => colonne IV donc.
        If Not c Is Nothing Then Cells(i, 3) = c.Offset(, 1): Set c = Nothing
    Next i
    [iu:iv].ClearContents    'on efface ensuite les colonnes IU:IV
End Sub

UN GRAND MERCI vbanew et vive ce forum! C'est ce que je désirais! Merci!!

Bonjour à tous,

Autre solution avec ménage préliminaire

https://www.excel-pratique.com/~bigfiles/doc/naz4_Concat.zip

Sub Concat()
Dim Lg%, i%, Cpt As Byte, x
''Macros par Claude Dubois pour "naz4" Excel-Pratique le 21/07/10
    x = Time
    Application.ScreenUpdating = False
    Lg = Range("A65536").End(xlUp).Row
    '--- retire vides ---
    Range("a2:a" & Lg).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    '--- retire doublons ---
    Range("a1:b" & Lg).AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
    Range("d1"), Unique:=True

        Columns("a:c").Delete
        Lg = Range("A65536").End(xlUp).Row
    '--- tri ---
    Range("a1:b" & Lg).Sort Key1:=Range("a2"), Order1:=xlAscending, Key2:=Range("b2") _
    , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom
    '--- concatener ---
        Cells(1, 4) = Cells(1, 1) 'titre
        Cells(1, 5) = Cells(1, 2)

        For i = 2 To Lg
            Cells(i, 4) = Cells(i, 1)
            Cells(i, 5) = Cells(i, 2)
            If IsError(Cells(i + 1, 1)) Then Exit For 'certaines cellules =#VALEUR!
                If Cells(i + 1, 1) = Cells(i, 1) Then
                    Cpt = 1
                    Do While Cells(i + Cpt, 1) = Cells(i, 1)
                        Cells(i, 5) = Cells(i, 5) & "," & Cells(i + Cpt, 2)
                        Cpt = Cpt + 1
                    Loop
                    i = i + Cpt - 1
                End If
        Next i
    Columns("a:c").Delete
    Range("a2:a" & Lg).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("a:b").Columns.AutoFit
    Application.ScreenUpdating = True
    MsgBox ("temps macro = " & Format(Time - x, "hh:mm:ss"))
End Sub

Bonne journée

Claude

Merci beaucoup Claude! C'est ce que je recherchais, cependant quand je veux l'adapter à mon fichier et mes données, j'ai un message d'erreur 1004 "Pas de cellules correspondantes".

Sub Concat()
Dim Lg%, i%, Cpt As Byte, x
   x = Time
    Application.ScreenUpdating = False
    Lg = Range("A65536").End(xlUp).Row
    '--- retire vides ---
   Range("a2:a" & Lg).SpecialCells(xlCellTypeBlanks).EntireRow.Delete  '--- LE PB EST ICI---
   Range("a1:b" & Lg).AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
    Range("d1"), Unique:=True

        Columns("a:c").Delete
        Lg = Range("A65536").End(xlUp).Row
    '--- tri ---
   Range("a1:b" & Lg).Sort Key

Quelqu'un connait-il la raison de cela, y'a t-il quelquechose à modifier dans le code pour passer d'un fichier à l'autre?

(Pour l'utiliser dans mon fichier, j'ai executer la macro liée au fichier fref-veh mais peut-on insérer un module dans notre fichier et faire un copier/coller ou y'a -t-il un autre moyen?

Cordialement

Naz4

re,

l'erreur doit venir du fait que ton fichier n'a pas de vide à supprimer, essaye :

    '--- retire vides ---
On Error Resume Next
  Range("a2:a" & Lg).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

Tu copie le code entier dans un Module de ton fichier

la structure doit être la même, sinon code à adapter

Claude

Re,

Salut claude,

Encore un autre code, version optimisée (60 à 70 fois plus rapide) par rapport au code que j'ai posté plus haut, toujours avec la méthode du Dictionnaire. Une fois qu'on a compris cette méthode, elle peut être très utile !

Sub concat2()
Dim newtblo As Object
Dim cel As Range, plage As Range
Dim i As Long, taillePlg As Long
Dim t As Single
Dim elt As String

    t = Timer
    Application.ScreenUpdating = False
    On Error Resume Next
    ActiveSheet.ShowAllData    'supprime le filtrage
    [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete    'supprime les lignes dont la colonne A est vide
    On Error GoTo 0

    Set newtblo = CreateObject("Scripting.Dictionary")
    Set plage = Range("a2:a" & [a65536].End(xlUp).Row)
    For Each cel In plage
        If Not newtblo.Exists(cel.Value) Then
            newtblo.Item(cel.Value) = cel.Offset(, 1).Value & "/"
        Else
            If Not (newtblo.Item(cel.Value) Like cel.Offset(, 1).Value & "/*" Or _
                    newtblo.Item(cel.Value) Like "*/" & cel.Offset(, 1).Value & "/*") Then
                newtblo.Item(cel.Value) = newtblo.Item(cel.Value) & cel.Offset(, 1).Value & "/"
            End If
        End If
    Next cel
    taillePlg = plage.Count
    ReDim tablo(1 To taillePlg, 0)
    For Each cel In plage
        elt = newtblo.Item(cel.Value)
        i = i + 1
        tablo(i, 0) = IIf(elt = "/", "", CStr(Mid(elt, 1, Len(elt) - 1)))
    Next cel
    [b2].Resize(taillePlg - 1, 1) = tablo
    Columns("B:B").NumberFormat = "@"
    Columns("A:C").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                        DataOption1:=xlSortNormal

    MsgBox Timer - t & " s"

End Sub

Merci à vba-news et Claude, mais je reste avec un pb en essayant de l'insérer dans ma feuille de travail. Voila mon code que j'ai modifié (A equivaut à AR et B à S). (En effet, il est beaucoup plus rapide lorsque je le teste sur la feuille à 2 colonnes):

Sub concat2()
Dim newtblo As Object
Dim cel As Range, plage As Range
Dim i As Long, taillePlg As Long
Dim t As Single
Dim elt As String

    t = Timer
    Application.ScreenUpdating = False
    On Error Resume Next
    ActiveSheet.ShowAllData    'supprime le filtrage
   [AR:AR].SpecialCells(xlCellTypeBlanks).EntireRow.Delete    'supprime les lignes dont la colonne AR est vide
   On Error GoTo 0

    Set newtblo = CreateObject("Scripting.Dictionary")
    Set plage = Range("AR4:AR" & [AR65536].End(xlUp).Row)
    For Each cel In plage
        If Not newtblo.Exists(cel.Value) Then
            newtblo.Item(cel.Value) = cel.Offset(, 1).Value & "/"
        Else
            If Not (newtblo.Item(cel.Value) Like cel.Offset(, 1).Value & "/*" Or _
                    newtblo.Item(cel.Value) Like "*/" & cel.Offset(, 1).Value & "/*") Then
                newtblo.Item(cel.Value) = newtblo.Item(cel.Value) & cel.Offset(, 1).Value & "/"
            End If
        End If
    Next cel
    taillePlg = plage.Count
    ReDim tablo(1 To taillePlg, 0)
    For Each cel In plage
        elt = newtblo.Item(cel.Value)
        i = i + 1
        tablo(i, 0) = IIf(elt = "/", "", CStr(Mid(elt, 1, Len(elt) - 1)))
    Next cel
    [b2].Resize(taillePlg - 1, 1) = tablo
    Columns("AS:AS").NumberFormat = "@"
    Columns("AR:AT").Sort Key1:=Range("AR4"), Order1:=xlAscending, Header:=xlGuess, _
                        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                        DataOption1:=xlSortNormal

    MsgBox Timer - t & " s"

End Sub

Lorsque je l'execute, pas d'erreur signalée mais une colonne AR avec des référence qui ont changé de place (triées peut-être?) et une colonne AS inchangée. Je ne sais plus trop quoi faire. Aves le code de Claude, j'obtiens une erreur 6 à la ligne:

Do While Cells(i + Cpt, 1) = Cells(i, 1)
                        Cells(i, 5) = Cells(i, 5) & "," & Cells(i + Cpt, 2)
                        Cpt = Cpt + 1 'L ERREUR EST ICI
                    Loop

Et en plus il me modifie mon tableau dans une autre cellule au debut de mon fichier.

Merci de votre aide