XL 2016 regrouper dans une cellule des valeurs avec tronc commun

T

Tontontonio

XLDnaute Nouveau
bonjour à tous,
dans une colonne, il y a des références du type AAaaabbb1
je souhaiterai regrouper dans une cellule toutes les références ayant le aaa en commun.
quelqu'un aurait-il une idée?
merci d'avance,
et bonne année à tous et à toutes.
 
Trier par date Trier par votes
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour Tonio, bonjour le forum,

Aucune indication sur la colonne de départ ni où renvoyer les données !?... Tu adapteras le code ci-dessous
VB: 
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim COL As Integer 'déclare la variable COL (COLonne)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
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 TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim LR As Integer 'déclare la variable LR (Ligne de référence)
Dim TC As String 'déclare la variable TC (Texte Concaténé)

Set O = Worksheets("Feuil1") 'définit l'onglet O (à adapter à ton cas)
COL = 1 'définit la colonne COL (à adapter à ton cas)
DL = O.Cells(Application.Rows.Count, COL).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne COL de l'onglet O
TV = O.Range(O.Cells(1, COL), O.Cells(DL, COL)) 'définit la tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 1 To DL 'boucle sur toutes les lignes I du tableau des valeurs TV (commencer à 2 si la colonne a une en-tête)
    D(Mid(TV(I, 1), 3, 3)) = "" 'alimente le dictionnaire D avec les 3 caractères après le second, de la donnée ligne I colonne 1 de TV
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temposraire TMP, la liste des éléments du dictionnare D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tabelau temporaire TMP
    Erase TL: K = 0: TC = "" 'vide le tableau TL, réinitialise la variable K, efface le texte concaténé TC
    For I = 1 To DL 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (commencer à 2 si la colonne a une en-tête)
        If Mid(TV(I, 1), 3, 3) = TMP(J) Then 'condition : si les 3 caractères après le second de la donnée ligne I colonne 1 de tv correspondent a l'élément J de TMP
            K = K + 1 'incrémente K
            ReDim Preserve TL(1 To K) 'redimensionne le tableau des lignes TL
            TC = IIf(TC = "", TV(I, 1), TC & ", " & TV(I, 1)) 'définit ou redéfinit le texte concaténé TC
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    LR = IIf(O.Cells(1, COL + 2).Value = "", 1, O.Cells(Application.Rows.Count, COL + 2).End(xlUp).Row + 1) 'définit la ligne de référence
    O.Cells(LR, COL + 2).Value = TC 'renvoie TC la la ligne TC, colonne C+2 (à adapter)
Next J 'prochaine élément de la boucle 1
End Sub
 
Vote positif 0 Vote négatif
T

Tontontonio

XLDnaute Nouveau
Rouge à dit:
Bonjour,

Essayez ceci

Cdlt
Cliquez pour agrandir...
bonsoir Rouge,
merci pour votre promptitude à répondre.
ça répond pile à la question posée, mais je m’aperçois que la question était mal formulée.
en fait je souhaiterai que pour chaque référence de la colonne A soit renvoyé en colonne B une chaîne concaténée des références ayant le tronc commun des 3 lettres identiques.
j'ai mis le fichier ce coup-ci pour que vous puissiez voir à quoi ça ressemble.
bonne soirée.
Tonio.
 

Pièces jointes

  • essai.xlsx
    15.1 KB · Affichages: 6
Vote positif 0 Vote négatif
T

Tontontonio

XLDnaute Nouveau
Robert à dit:
Bonjour Tonio, bonjour le forum,

Aucune indication sur la colonne de départ ni où renvoyer les données !?... Tu adapteras le code ci-dessous
VB: 
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim COL As Integer 'déclare la variable COL (COLonne)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
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 TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim LR As Integer 'déclare la variable LR (Ligne de référence)
Dim TC As String 'déclare la variable TC (Texte Concaténé)

Set O = Worksheets("Feuil1") 'définit l'onglet O (à adapter à ton cas)
COL = 1 'définit la colonne COL (à adapter à ton cas)
DL = O.Cells(Application.Rows.Count, COL).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne COL de l'onglet O
TV = O.Range(O.Cells(1, COL), O.Cells(DL, COL)) 'définit la tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 1 To DL 'boucle sur toutes les lignes I du tableau des valeurs TV (commencer à 2 si la colonne a une en-tête)
    D(Mid(TV(I, 1), 3, 3)) = "" 'alimente le dictionnaire D avec les 3 caractères après le second, de la donnée ligne I colonne 1 de TV
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temposraire TMP, la liste des éléments du dictionnare D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tabelau temporaire TMP
    Erase TL: K = 0: TC = "" 'vide le tableau TL, réinitialise la variable K, efface le texte concaténé TC
    For I = 1 To DL 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (commencer à 2 si la colonne a une en-tête)
        If Mid(TV(I, 1), 3, 3) = TMP(J) Then 'condition : si les 3 caractères après le second de la donnée ligne I colonne 1 de tv correspondent a l'élément J de TMP
            K = K + 1 'incrémente K
            ReDim Preserve TL(1 To K) 'redimensionne le tableau des lignes TL
            TC = IIf(TC = "", TV(I, 1), TC & ", " & TV(I, 1)) 'définit ou redéfinit le texte concaténé TC
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    LR = IIf(O.Cells(1, COL + 2).Value = "", 1, O.Cells(Application.Rows.Count, COL + 2).End(xlUp).Row + 1) 'définit la ligne de référence
    O.Cells(LR, COL + 2).Value = TC 'renvoie TC la la ligne TC, colonne C+2 (à adapter)
Next J 'prochaine élément de la boucle 1
End Sub
Cliquez pour agrandir...
bonsoir Robert,
merci beaucoup pour ta proposition.
comme je disais à Rouge, ma question était mal posée, ce que je recherche, c'est d'avoir en colonne B pour chaque référence, le renvoie de la chaîne concaténée, comme c'est le cas pour la ligne 1.
ta solution fonctionne sur la première ligne, mais ensuite renvoie un résultat décalé de plusieurs lignes.
il m'a semblé comprendre que lorsque les références de la colonne A on été trouvée, elles ne sont plus testée.
je joins le tableau avec les références, j'aurais du commencer par là, pas l'habitude des forums, c'est nouveau pour moi.
merci encore,
bonne soirée,
Tonio.
 

Pièces jointes

  • essai.xlsx
    15.1 KB · Affichages: 3
Vote positif 0 Vote négatif
R

Rouge

XLDnaute Impliqué
Bonjour,

Voici la modification
VB: 
Sub Extraction()
    Dim i As Long, j As Long, DerLig As Long
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    Columns("B:C").ClearContents 'effacement des précédents résultats
    Range("B1:B" & DerLig).FormulaR1C1 = "=MID(RC[-1],3,3)" 'Extraction de la référence
    Range("B1:B" & DerLig).Value = Range("B1:B" & DerLig).Value
    Range("A1:B" & [B1].CurrentRegion.Rows.Count + 1).Sort [B1], 1 'Fitrage
    
    For i = DerLig To 2 Step -1 'suppression des doublons
        If Cells(i, 2) = Cells(i - 1, 2) Then Cells(i, 2).Delete
    Next i
    
    For i = 1 To DerLig 'Récupération des données
        Ref = Cells(i, 2)
        Set Dest = Cells(i, 3)
        For j = 2 To DerLig
            If InStr(1, Cells(j, "A"), Ref, 0) > 0 Then Dest = Dest & ", " & Cells(j, "A")
        Next j
        Cells(i, 3).Value = Right(Dest, Len(Dest) - 2)
    Next i
    Set Dest = Nothing
End Sub

Cdlt
 

Pièces jointes

  • Tontontonio_regrouper dans une cellule des valeurs avec tronc commun_2.xlsm
    25.3 KB · Affichages: 5
Vote positif 0 Vote négatif
T

Tontontonio

XLDnaute Nouveau
Rouge à dit:
Bonjour,

Voici la modification
VB: 
Sub Extraction()
    Dim i As Long, j As Long, DerLig As Long
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    Columns("B:C").ClearContents 'effacement des précédents résultats
    Range("B1:B" & DerLig).FormulaR1C1 = "=MID(RC[-1],3,3)" 'Extraction de la référence
    Range("B1:B" & DerLig).Value = Range("B1:B" & DerLig).Value
    Range("A1:B" & [B1].CurrentRegion.Rows.Count + 1).Sort [B1], 1 'Fitrage
   
    For i = DerLig To 2 Step -1 'suppression des doublons
        If Cells(i, 2) = Cells(i - 1, 2) Then Cells(i, 2).Delete
    Next i
   
    For i = 1 To DerLig 'Récupération des données
        Ref = Cells(i, 2)
        Set Dest = Cells(i, 3)
        For j = 2 To DerLig
            If InStr(1, Cells(j, "A"), Ref, 0) > 0 Then Dest = Dest & ", " & Cells(j, "A")
        Next j
        Cells(i, 3).Value = Right(Dest, Len(Dest) - 2)
    Next i
    Set Dest = Nothing
End Sub

Cdlt
Cliquez pour agrandir...
bonjour Rouge,
ça fonctionne sur le fichier que je vous ai posté,
mais si j'essaie de rallonger la liste des références de la colonne A l'extraction ne fonctionne plus.
j'ai rajouté 5 références en fin de liste, il les a ordonnées, elles se retrouvent en haut de la liste, mais pas d'extraction, je vous met le nouveau fichier en PJ.
merci pour aide.
Tonio.
 

Pièces jointes

  • EXTRACTION.xlsm
    27.4 KB · Affichages: 7
Vote positif 0 Vote négatif
T

Tontontonio

XLDnaute Nouveau
Rouge à dit:
Petite erreur sur une ligne du code
Remplacez
For j = 2 To DerLig
par
For j = 1 To DerLig

Et ça devrait aller

Cdlt
Cliquez pour agrandir...
ça fait le boulot, super!
j'ai rajouté une colonne F avec la formule
=INDEX($C$1:$C$377;EQUIV(FAUX; ESTERREUR( CHERCHE($B$1:$B$44;$D1)); 0)) (je l'ai trouvée sur internet)
de manière à remettre en face de chaque référence la chaîne qui lui revient.
Merci beaucoup Rouge, pour cette aide précieuse.
passez une bonne journée.
Tonio
 
Vote positif 0 Vote négatif

Discussions similaires

C
  • Question
Microsoft 365 Transposer des valeurs en 2 colonnes en fonction d'une référence produit
Réponses
9
Affichages
311
Cagnet
C
Phoenix23
  • Question
XL 2016 Erreur #VALEUR
Réponses
9
Affichages
192
sylvanu
sylvanu
F
  • Résolu(e)
XL 2019 Plusieurs lignes avec mêmes donnés
2
Réponses
23
Affichages
277
DJunqueira
D
R
  • Question
Microsoft 365 Classement avec valeurs identiques
Réponses
3
Affichages
276
Cousinhub
Cousinhub
Phoenix23
  • Question
XL 2016 Différencier par année des données dans une feuille tableau
Réponses
2
Affichages
135
Phoenix23
Phoenix23
Hayholten
  • Question
Microsoft 365 [MFC Excel] Simplification des Règles
Réponses
9
Affichages
458
lav
L
J
  • Résolu(e)
XL 2019 Vérifier si 2 cellules ont un mot en commun
Réponses
3
Affichages
687
mapomme
mapomme
H
  • Question
XL 2016 fonctions "INDIRECT" et vers une plage de matrice "changeable" dans une autre feuille
Réponses
6
Affichages
274
HIMCHO
H
S
  • Question
XL 2016 Chercher un mot en commun dans deux colonnes différentes
2
Réponses
17
Affichages
729
patricktoulon
patricktoulon
H
  • Question
XL 2016 fonction FILTRE sur Excel 2016
Réponses
9
Affichages
449
Hynnuh
H

Membres actuellement en ligne

8 membres et 99 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 305
Messages
2 087 081
Membres
103 457
dernier inscrit
fab2614