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!
Le mieux serait que tu me mettes manuellement le résultat que tu souhaites obtenir. Mais je vais essayer de faire avec ce que j'ai compris.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
- Messages
- 9'246
- Excel
- Vista Office 2007FR
- Inscrit
- 08/12/2007
- Emploi
- retraité Sce.Méthodes
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 !
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 :
J'ai bien peur qu'en vraie débutante, la tâche n'est pas aisée ! Mais je vais essayer de mettre 2-3 explications et faire 2-3 modifs dans le code pour que tu puisses mieux le comprendre.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!!
- Messages
- 9'246
- Excel
- Vista Office 2007FR
- Inscrit
- 08/12/2007
- Emploi
- retraité Sce.Méthodes
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
- Messages
- 9'246
- Excel
- Vista Office 2007FR
- Inscrit
- 08/12/2007
- Emploi
- retraité Sce.Méthodes
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