FUSIONNER / CONCATENER des DOUBLONS

C

Ctrl-Alt-Suppr

XLDnaute Junior
Bonsoir à tous,

Votre forum est vraiment très complet, mais après 1h de recherche, je me suis inscrits car je n'ai pas trouvé mon "bonheur".
En fait, ce que j'aimerai faire ne me parait pas très compliqué, mais pourtant je colle ...


Imaginez que je cherche à comparer des voitures ... (ex. complétement fictif)

colonneA ___ colonneB

PORSCHE ___ cuir
PORSCHE ___ 12 airbags
PORSCHE ___ 400 ch
SKODA _____ tissu
SKODA _____ 1 moitié d'airbag
SKODA _____ 1 cheval
SKODA _____ 1 attache-remorque


Ce que j'aimerai, c'est remettre sur une même ligne (si possible en rajoutant des caractères de séparation) les valeurs des "doublons" de la colonne A.

En clair :

PORSCHE ___ cuir / 12 airbags / 400 ch
SKODA _____ tissu / 1 moitié d'airbag / 1 cheval / 1 attache-remorque

J'ai bien essayé avec des SI(xxxx) et des & ... mais mon problème c'est que le nombre de "caractérisitiques pour chaque voiture" est différent, donc ma formule n'est pas recopiable.
Oui, car en tout, j'ai au moins 15.000 lignes ...


A savoir, je ne suis pas du tout programmeur (VBA, macros ...)
Toute aide, même partielle est la bienvenue car c'est assez important ...
Si cela doit se faire en plusieurs étapes (genre sur 3 colonnes supplémentaires) ce n'est pas génant.


En espérant que certains prendront le peine de m'aider ...
D'avance, merci !

Cordialement.
 
Trier par date Trier par votes
E

erilen

XLDnaute Nouveau
erilen à dit:
bonjour tout le monde,
je besoins d'aide pour faire le suivant fichier avec les doublons...s'il vous plait aide moi.
Cliquez pour agrandir...

J'ai, mais je doublais la dernière valeur de chaque ligne

Sub Concatener()
Dim DerLig As Long, A As Long, G As Long 'Dimensionnement des variables de boucle
Dim MaConcat As String 'Dimensionnement de la variable texte
DerLig = Cells(Columns(1).Cells.Count, 1).End(xlUp).Row 'récupère le n° de la dernière ligne remplie
MaConcat = Sheets("feuil1").Cells(A + 2, 2).Value 'Récupère la première Pression
For A = 2 To DerLig 'Boucle qui passe sur toutes les lignes de 2 à la dernière
If Cells(A, 1) = Cells(A + 1, 1) Then 'Si la valeur de la colonne 1 de la cellule vérifiée est = à la suivante
MaConcat = MaConcat & "," & Cells(A + 1, 2) 'Alors adaptation du texte avec la valeur de la colonne B de la ligne suivante
Else 'Sinon
Cells(G + 2, 5) = Cells(A, 1) 'On place dans la colonne E le Code
Cells(G + 2, 6) = MaConcat 'On place dans la colonne F la Pression
MaConcat = Cells(A, 2) 'On recommence le texte au suivant
G = G + 1 'On incrémente la ligne de destination du résultat
End If
Next A
End Sub
 
Vote positif 0 Vote négatif
E

erilen

XLDnaute Nouveau
gosselien à dit:
Bonjour,

ce n'est pas un fichier XL ça mais un pdf, on ne sait pas faire grand chose avec...

Un fichier anonymisé serait bienvenu :)

P.
Cliquez pour agrandir...
ici mon VB..il 'y avez des erreurs mais je suis nulle...
Sub Concatener()
Dim DerLig As Long, i As Long, j As Long 'Dimensionnement des variables de boucle
Dim MaConcat As String 'Dimensionnement de la variable texte
DerLig = Cells(Columns(1).Cells.Count, 1).End(xlUp).Row 'récupère le n° de la dernière ligne remplie
MaConcat = Sheets("feuil1").Cells(i + 2, 2).Value 'Récupère la première Pression
For i = 2 To DerLig 'Boucle qui passe sur toutes les lignes de 2 à la dernière
If Cells(i, 1) = Cells(i + 1, 1) Then 'Si la valeur de la colonne 1 de la cellule vérifiée est = à la suivante
MaConcat = MaConcat & "_" & Cells(i + 1, 2) 'Alors adaptation du texte avec la valeur de la colonne B de la ligne suivante
Else 'Sinon
Cells(j + 2, 5) = Cells(i, 1) 'On place dans la colonne E le Code
Cells(j + 2, 6) = MaConcat 'On place dans la colonne F la Pression
MaConcat = Cells(i, 2) 'On recommence le texte au suivant
j = j + 1 'On incrémente la ligne de destination du résultat
End If
Next i
End Sub
 
Vote positif 0 Vote négatif
E

erilen

XLDnaute Nouveau
BISSON Nicole à dit:
Bonjour,

Code: 
Sub RegroupeSansDoublons()
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In Range("a2", [a65000].End(xlUp))
     If Not mondico.exists(c.Value) Then
        mondico(c.Value) = c.Offset(, 1).Value
     Else
        mondico(c.Value) = mondico(c.Value) & "," & c.Offset(, 1).Value
     End If
  Next c
  [D2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [E2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

BISSON
Cliquez pour agrandir...

MERCI MERCI!!!!!! sa marche très bien
 
Vote positif 0 Vote négatif
gosselien

gosselien

XLDnaute Barbatruc
re,

sur base du fichier que tu as déposé :)

P.

Edit: pas vule message précédant de Nicole :(

VB: 
Option Explicit

Sub EnColonne()
Dim d1, d2, d3, c
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
For Each c In Range("a1", [a65000].End(xlUp))
   If Not d1.Exists(c.Value) Then
      d1(c.Value) = c.Offset(0, 1) ' ajout dans dictionnaire
   Else
      d1(c.Value) = d1(c.Value) & "," & c.Offset(0, 1) ' 1 colonne après la première
   End If
   If Not d2.Exists(c.Value) Then
      d2(c.Value) = c.Offset(0, 2)
   Else
      d2(c.Value) = d2(c.Value) & "," & c.Offset(0, 2) ' 2e colonne après la première
   End If
   If Not d3.Exists(c.Value) Then
      d3(c.Value) = c.Offset(0, 3)
   Else
      d3(c.Value) = d3(c.Value) & "," & c.Offset(0, 3) '3e colonne après la première
   End If
Next c
If d1.Count = 0 Then Exit Sub
[f2].Resize(d1.Count) = Application.Transpose(d1.keys)
[g2].Resize(d1.Count) = Application.Transpose(d1.items)
[h2].Resize(d2.Count) = Application.Transpose(d2.items)
[i2].Resize(d3.Count) = Application.Transpose(d3.items)
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
E

erilen

XLDnaute Nouveau
gosselien à dit:
re,

sur base du fichier que tu as déposé :)

P.

Edit: pas vue le message précédant de Nicole :(

VB: 
Option Explicit

Sub EnColonne()
Dim d1, d2, d3, c
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
For Each c In Range("a1", [a65000].End(xlUp))
   If Not d1.Exists(c.Value) Then
      d1(c.Value) = c.Offset(0, 1) ' ajout dans dictionnaire
   Else
      d1(c.Value) = d1(c.Value) & "," & c.Offset(0, 1) ' 1 colonne après la première
   End If
   If Not d2.Exists(c.Value) Then
      d2(c.Value) = c.Offset(0, 2)
   Else
      d2(c.Value) = d2(c.Value) & "," & c.Offset(0, 2) ' 2e colonne après la première
   End If
   If Not d3.Exists(c.Value) Then
      d3(c.Value) = c.Offset(0, 3)
   Else
      d3(c.Value) = d3(c.Value) & "," & c.Offset(0, 3) '3e colonne après la première
   End If
Next c
If d1.Count = 0 Then Exit Sub
[f2].Resize(d1.Count) = Application.Transpose(d1.keys)
[g2].Resize(d1.Count) = Application.Transpose(d1.items)
[h2].Resize(d2.Count) = Application.Transpose(d2.items)
[i2].Resize(d3.Count) = Application.Transpose(d3.items)
End Sub
Cliquez pour agrandir...


merci, mais ca ne marche pas :(
 
Vote positif 0 Vote négatif
S

Shou

XLDnaute Nouveau
Hello !!

J'ai besoin d'aide sur un fichier .

J'ai essayer d'adapter la macro donnée plus haut mais sans succès.... :(

Je chercher à ce que tous les doublons des références sois supprimer et avoir en face les lignes correspondantes concatener

Je m'explique:

Dans l'onglet Extract du fichier excel ce trouve une extraction d'un logiciel.
Une même référence peut se trouver sur plusieurs lignes.
J'ai donc des références en doublons parfois jusqu'à 30 fois la même référence n'étant pas pour le même module et pouvant être sur plusieurs lignes (A,B,C,F...).

J'aimerais dans un nouvel onglet pouvoir retrouver une seule fois cette référence avec les lignes concatener dans la colonne à côté ( cf onglet Nouveau dans le fichier excel)
J'oublais, les références ne sont pas triées par ordre croissant on peu trouver une référence dans la première ligne excel puis ensuite dans la 68000ème ligne.

Je ne sais pas si c'est clair. J'essaye depuis deux jours. J'ai vraiment besoin de votre aide.

Merci d'avance
 

Pièces jointes

  • Classeur2.xlsx
    1.7 MB · Affichages: 61
Dernière édition:
Vote positif 0 Vote négatif
zebanx

zebanx

XLDnaute Accro
Bonsoir à tous

Un exemple avec un minimum de VBA (appelle à la fonction CONCAT) et quelques formules qui permettent de ne pas être contraint sur le nombre de lignes et de colonnes dans le code, me semble-t-il.

cdlt
thierry



@gosselien : jamais sans VBA (mais c'est si facile pour vous et quelques uns ici!) :D
 

Pièces jointes

  • concatener_colonne en ligne (regroup. valeur col.1).xls
    48 KB · Affichages: 44
Vote positif 0 Vote négatif
D

DariusBacchus

XLDnaute Nouveau
JYLL à dit:
Re : FUSIONNER / CONCATENER des DOUBLONS

Bonsoir CTRL-ALT-SUP, ninbihan et le forum,

En effet une solution par macro avec ce code et classeur joint.

Code: 
Sub Concatener()
Dim Ligne As Long, I As Long, J As Byte, Mémoire As String, Mot As String
For I = 1 To Range("A65536").End(xlUp).Row + 1
    If Left(Cells(I, 1), 8) <> Mémoire Then
    Mémoire = Left(Cells(I, 1), 8)
    If Ligne > 0 Then Cells(Ligne, 2) = Mot
        Ligne = Ligne + 1
        Mot = ""
        Mot = Cells(I, 1)
    Else
        J = Len(Cells(I, 1))
        While Mid$(Cells(I, 1), J, 1) <> "_"
            J = J - 1
        Wend
        Mot = Mot & " / " & Mid$(Cells(I, 1), J + 1, Len(Cells(I, 1)) - J + 1)
    End If
Next I
End Sub
Bon test.
Cliquez pour agrandir...
JYLL à dit:
Re : FUSIONNER / CONCATENER des DOUBLONS

Bonsoir CTRL-ALT-SUP, ninbihan et le forum,

En effet une solution par macro avec ce code et classeur joint.

Code: 
Sub Concatener()
Dim Ligne As Long, I As Long, J As Byte, Mémoire As String, Mot As String
For I = 1 To Range("A65536").End(xlUp).Row + 1
    If Left(Cells(I, 1), 8) <> Mémoire Then
    Mémoire = Left(Cells(I, 1), 8)
    If Ligne > 0 Then Cells(Ligne, 2) = Mot
        Ligne = Ligne + 1
        Mot = ""
        Mot = Cells(I, 1)
    Else
        J = Len(Cells(I, 1))
        While Mid$(Cells(I, 1), J, 1) <> "_"
            J = J - 1
        Wend
        Mot = Mot & " / " & Mid$(Cells(I, 1), J + 1, Len(Cells(I, 1)) - J + 1)
    End If
Next I
End Sub
Bon test.
Cliquez pour agrandir...
bonsoir Jean Yves,
merci pour ton post, ton code est propre et il fonctionne !
 
Vote positif 0 Vote négatif

Discussions similaires

ymanot
  • Résolu(e)
XL 2010 Macro pour mettre en surbrillance (jaune) des doublons (RESOLU)
Réponses
8
Affichages
610
ymanot
ymanot
E
  • Question
Fusionner une colonne sans doublons avec une colonne ayant des doublons
Réponses
2
Affichages
716
Elahzul
E
M
  • Question
Fusionner des lignes en doublon et additionner leurs valeurs
Réponses
3
Affichages
1 K
miliev83
M
O
  • Question
Ultime elimination des doublons :D
Réponses
1
Affichages
925
orphelion
O
cephalotus
  • Question
COMPTAGE et suppression des doublons en 2 façons
Réponses
0
Affichages
807
cephalotus
cephalotus

Membres actuellement en ligne

13 membres et 236 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 103
Messages
2 085 310
Membres
102 859
dernier inscrit
Diallokass