Autres Macro de mise en forme

[BoubouFrance]

Bonjour à toutes et à tous,

Je suis en total galère sur une macro de mise en forme et je ne sais pas comment m'y prendre.

J'ai un tableau de valeur que je souhaiterai uniformiser comme tel :

Tableau initial :

Prénom	Couleur	Motorisation
Julien	bleu	Voiture
Julien	Rouge	Voiture
Julien	Vert	Moto
Marc	Bleu	Voiture
Marc	Noir	Voiture
Lucie	Rouge	Moto

Tableau souhaité :

Prénom	Couleur	Motorisation
Julien	bleu, rouge, vert	voiture, moto
Marc	bleu, noir	voiture, moto
Lucie	rouge	moto

Je souhaiterai n'avoir qu'une ligne de prénom unique et les valeurs différentes associées.

Est ce quelqu'un aurait une idée ?

Un grand merci par avance pour votre aide

 

[TooFatBoy]

Bonjour,

De joindre un classeur exemple, le droit tu as. 😉

 

[BoubouFrance]

Autant pour moi, le voilà

 

[TooFatBoy]

Je viens de regarder ton fichier et j'ai enfin compris ce que tu veux, mais hélas je ne sais pas faire ça. 🙁

 

[sylvanu]

Bonsoir Bouboufrance, TooFatBoy,
En PJ un essai avec :

Sub Worksheet_Activate()
    Dim Couleur$, Motorisation$, Prénom$, DL%, L%, i%
    Application.ScreenUpdating = False
    [A2:A1000].ClearContents
    DL = Feuil1.Range("A65500").End(xlUp).Row                       ' Dernière ligne tableau
    Range("A2:A" & DL - 2) = Feuil1.Range("A4:A" & DL).Value        ' Copier Coller Prénoms dans Feuil2
    ActiveSheet.[A:A].RemoveDuplicates Columns:=1, Header:=xlYes    ' Suppression doublons
    With Feuil1
        For L = 2 To Range("A65500").End(xlUp).Row                  ' Pour tous les prénoms
            Prénom = Cells(L, "A"): Couleur = "": Motorisation = "" ' On récupère Couleur et Motorisation
            For i = 4 To DL                                         ' Pour toutes les lignes du tableau d'entrée
                If .Cells(i, "A") = Prénom Then                     ' Si c'est le même prénom
                    If InStr(1, Couleur, .Cells(i, "B")) = 0 Then   ' Si la couleur n'est pas présente on la rajoute
                        Couleur = Couleur & " , " & .Cells(i, "B")
                    End If
                    If InStr(1, Motorisation, .Cells(i, "C")) = 0 Then  ' Si la motorisation n'est pas présente on la rajoute
                        Motorisation = Motorisation & " , " & .Cells(i, "C")
                    End If
                End If
            Next i
            Cells(L, "B") = Mid(Couleur, 4)                         ' On copie les valeurs en supprimant la virgule initiale
            Cells(L, "C") = Mid(Motorisation, 4)
        Next L
    End With
    Columns.AutoFit                                                 ' On ajuste la largeur des colonnes
    [A:C].Borders.Weight = xlThin                                   ' On met les bordures
End Sub

La mise à jour est automatique lorsqu'on sélectionne la Feuil2.
NB: Dans votre tableau il y a une erreur. Marc c'est Bleu,Noir Voiture et non Bleu,Noir Voiture,moto.

 

[BoubouFrance]

Bonsoir Bouboufrance, TooFatBoy,
En PJ un essai avec :

Sub Worksheet_Activate()
    Dim Couleur$, Motorisation$, Prénom$, DL%, L%, i%
    Application.ScreenUpdating = False
    [A2:A1000].ClearContents
    DL = Feuil1.Range("A65500").End(xlUp).Row                       ' Dernière ligne tableau
    Range("A2:A" & DL - 2) = Feuil1.Range("A4:A" & DL).Value        ' Copier Coller Prénoms dans Feuil2
    ActiveSheet.[A:A].RemoveDuplicates Columns:=1, Header:=xlYes    ' Suppression doublons
    With Feuil1
        For L = 2 To Range("A65500").End(xlUp).Row                  ' Pour tous les prénoms
            Prénom = Cells(L, "A"): Couleur = "": Motorisation = "" ' On récupère Couleur et Motorisation
            For i = 4 To DL                                         ' Pour toutes les lignes du tableau d'entrée
                If .Cells(i, "A") = Prénom Then                     ' Si c'est le même prénom
                    If InStr(1, Couleur, .Cells(i, "B")) = 0 Then   ' Si la couleur n'est pas présente on la rajoute
                        Couleur = Couleur & " , " & .Cells(i, "B")
                    End If
                    If InStr(1, Motorisation, .Cells(i, "C")) = 0 Then  ' Si la motorisation n'est pas présente on la rajoute
                        Motorisation = Motorisation & " , " & .Cells(i, "C")
                    End If
                End If
            Next i
            Cells(L, "B") = Mid(Couleur, 4)                         ' On copie les valeurs en supprimant la virgule initiale
            Cells(L, "C") = Mid(Motorisation, 4)
        Next L
    End With
    Columns.AutoFit                                                 ' On ajuste la largeur des colonnes
    [A:C].Borders.Weight = xlThin                                   ' On met les bordures
End Sub

La mise à jour est automatique lorsqu'on sélectionne la Feuil2.
NB: Dans votre tableau il y a une erreur. Marc c'est Bleu,Noir Voiture et non Bleu,Noir Voiture,moto.

Merci de ton retour mais cela ne fonctionne pas et créé certains doublons.
Je suis sur un piste, je partagerai le fichier des lors que j'aurai réussi.
Encore merci pour le temps accorder à mon problème

 

[sylvanu]

Bonjour,
Normalement RemoveDuplicates supprime les doublons, il ne devrait pas y en avoir.
En attente de votre fichier.