Autres Macro de mise en forme

BoubouFrance

XLDnaute Nouveau
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énomCouleurMotorisation
JulienbleuVoiture
JulienRougeVoiture
JulienVertMoto
MarcBleuVoiture
MarcNoirVoiture
LucieRougeMoto
Tableau souhaité :

PrénomCouleurMotorisation
Julienbleu, rouge, vertvoiture, moto
Marcbleu, noirvoiture, moto
Lucierougemoto
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
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir Bouboufrance, TooFatBoy,
En PJ un essai avec :
VB:
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.
 

Pièces jointes

  • Classeur2 (4).xlsm
    17.9 KB · Affichages: 5
Dernière édition:

BoubouFrance

XLDnaute Nouveau
Bonsoir Bouboufrance, TooFatBoy,
En PJ un essai avec :
VB:
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
 

Discussions similaires

Statistiques des forums

Discussions
311 724
Messages
2 081 936
Membres
101 844
dernier inscrit
pktla