Discussion :

[rayba89]

Bonjour,

J'ai une feuille excel qui contient des identifiants ainsi que leurs attributs.
Pour chaque valeur d'un attribut, la ligne sera dupliqué (voir le premier tableau).
Je souhaite simplifier mon tableau afin d'obtenir une ligne pour chaque identifiant (voir le deuxieme tableau), sachant que :
-si la meme valeur de l'attribut se represente pour un identifiant -> je ne la rajoute plus
-ne pas rajouter les valeurs nulles
-ne pas effacer les lignes avant d'avoir tourner cet algo pour touts les autres attributs

En pj un exemple qui illustre le resultat attendu.

J'ai fais le code suivant qui fonctionne plutot bien:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
lngRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
   For x = 2 To lngRow
        If ActiveSheet.Cells(x, 1).Value <> "" Then
                    aux = VBA.CInt(ActiveSheet.Cells(x, 1).Value)
 
                    aux_init = ActiveSheet.Cells(x, 2).Value
                    aux_Attr1 = ActiveSheet.Cells(x, 2).Value
 
                    y = x + 1
                         For y = lngRow To x + 1 Step -1
                                If ActiveSheet.Cells(y, 1) = aux Then
                                     If ActiveSheet.Cells(y, 2).Value <> aux_Attr1 And  ActiveSheet.Cells(y, 2).Value <> aux_init Then
                                            aux_Attr1 = ActiveSheet.Cells(y, 2).Value
                                            If ActiveSheet.Cells(x, 2) <> "" And ActiveSheet.Cells(y, 2) <> "" Then
ActiveSheet.Cells(x, 2) = ActiveSheet.Cells(x, 2) & ";" & ActiveSheet.Cells(y, 2)
ElseIf ActiveSheet.Cells(x, 2) = "" And ActiveSheet.Cells(y, 2) <> "" Then
ActiveSheet.Cells(x, 6) = ActiveSheet.Cells(x, 2) & ActiveSheet.Cells(y, 2)
                                            End If
                                     End If                             
ActiveSheet.Rows(y).EntireRow.Delete
                                End If
                        Next y
        End If
        Next x

J'ai fait le meme algo pour tout les attributs (avant de faire le EntireRow.delete) mais ca fait une centaine de ligne de code!!

Ca fonctionne bien sauf que pour effectuer le meme algo (mais entre deux chaines de caratere au lieu des colonnes ) Marc-L m'avait aidé a simplifier mon code, en creant une fonction de 5 lignes de code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Function Completer$(ByVal S1$, ByVal S2$)
         Dim SP$()
         SP = Split(S1, ",")
 
         For Each MOT In Split(S2, ",")
             If IsError(Application.Match(MOT, SP, 0)) Then
                 ReDim Preserve SP(UBound(SP) + 1)
                 SP(UBound(SP)) = MOT
             End If
         Next
 
         Completer = Join(SP, ",")
End Function
 
Private Sub demo()
Cells(5, 3).Value = Completer(Cells(5, 3).Value, Cells(4, 3).Value)
 
End Sub

J'essaye d'adapter cette fonction pour mon exemple mais j'y arrive pas ( vu que les methodes s'appliquent juste sur les chaines de caract' )

J'aimerais simplifier mon algo avec une fonction pareil, qui prend juste les numero de colonnes en input, les comparent, et fait la concatenation pour les attributs.

Merci pour tout aide!

[Marc-L]

Bonjour,

tu aurais certainement eu des réponses si tu avais exposé ton besoin dans la section adéquate, Macros et VBA Excel …

Merci de mettre un fichier exemple en pièce jointe avec de vrais attributs pour voir ce que l'on peut faire …

[rayba89]

Bonjour,

Ci-joint un exemple concret, sauf que dans mon classeur y'a une trentaine d'attributs, et du coup ca fait bcp de lignes de code faire une fonction me simplifierait bcp la tache!

D'habitude pour un meme identifiant, dans mon classeur source, lorsque les attributs sont identiques il seront inserés sur deux lignes consecutifs.

Dans l'exmple je prend le cas contraire, histoire de perfectionner un peu l'algo.

avec mon code, si deux attributs identiques pour le meme identifiants se succedent (lignes consécutifs ), il seront pas dupliqués! et donc dans cet exemple le code ne fonctionne pas parfaitement mais je vais le changer.

Merci bcp pour ton aide!

les pj

[Marc-L]

Je ne peux rien tester à partir d'une feuille vierge ‼

Sinon tu peux enregistrer ton fichier en .xls avec de vrais attributs pour le mettre en pièce jointe …

[rayba89]

Dsl j'avais attaché le mauvais fichier!

[Marc-L]

Faut-il remplacer les données d'origine ou bien copier le tableau résultat ailleurs ?

[rayba89]

Remplacer les données d'origine! (il s'agit d'un extract d'une database, qui donne suite a un tableau pareil, je cherche a le simplifier)

[Marc-L]

Code à insérer dans le module de classe de la feuille de calculs :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
'   Référence à cocher via le menu Outils :     Microsoft Scripting Runtime
 
Sub RegrouperID()
    Const S$ = ", ":  Dim Dict As New Dictionary
    VA = Me.[A1].CurrentRegion.Value:  UC& = UBound(VA, 2):  UR& = UBound(VA)
 
    For R& = 2 To UR
        If Not Dict.Exists(VA(R, 1)) Then Dict.Add VA(R, 1), Dict.Count + 1
    Next
 
    ReDim ID(1 To UR - 1, 1 To UC)
    For R = 1 To Dict.Count:  ID(R, 1) = Dict.Keys(R - 1):  Next
 
    If UC > 1 Then
        For R = 2 To UR
            L& = Dict.Item(VA(R, 1))
 
            For C& = 2 To UC
                T$ = Trim(VA(R, C))
                If T > "" Then If InStr(S & ID(L, C) & S, S & T & S) = 0 Then _
                                 ID(L, C) = ID(L, C) & IIf(ID(L, C) > "", S, "") & T
            Next
        Next
    End If
 
    Me.[A2].Resize(UR - 1, UC).Value = ID
    Dict.RemoveAll:  Set Dict = Nothing:  Erase ID, VA
    If UC > 1 Then Me.[A1].CurrentRegion.Columns("B:" & Chr$(64 + UC)).AutoFit
End Sub

_______________ ____________________________________ ______________________________

Merci de cliquer sur pour chaque message ayant aidé puis sur pour clore cette discussion …

__________________________________________________________________________________________
We are all very ignorant, what happens is that not all ignore the same things … (Albert Einstein)

[rayba89]

Bonjour Marc,

Ca marche parfaitement
L'avantage de ce forum est qu'en plus d'avoir des reponses/solutions à nos besoins, ca nous pousse a creuser pour comprendre comment vous vous etes parvenus a trouver ces solutions!
à moi de decrypter et de comprendre le code mnt, de premiere vue la tache me semble pas evidente! mais j'evolue rapidemment grace a tes bouts de code et ton aide

Merci infiniment pour ton aide, et le temps que tu m'as accordé !