XL 2016 regrouper dans une cellule des valeurs avec tronc commun

Rouge à dit:

Bonjour,

Essayez ceci

Cdlt

Cliquez pour agrandir...

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...

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...

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...