XL 2010 transposer plusieurs lignes-même ID

djam28 · 11 Mars 2022

Bonsoir à tous,
Je fais appel à vos lumières pour résoudre un souci de traitement de données. Mon problème est le suivant:
J'ai une base de donnée contenant des patients en doublant. chaque doublon (ligne du meme id) correspond à un événement (il pourrait en avoir plusieurs). Je voudrais que les données des doublons soient transposer sur une seule ligne (ligne = eligibily_enrol_arm1). J'ai mis un code couleur pour mettre en évidence les cutoff des colonnes
Le resultat souhaité est dans l'onglet 2 (=resultat)
Dites moi si vous voulez plus de précisions
Merci beaucoup+++
Bonne soirée
DE

djam28 · 12 Mars 2022

Bonjour Yal,
C'est magique, mille mercis

Bonne soirée
DE

yal · 12 Mars 2022

Bonjour
Une proposition en VBA

djam28 · 12 Mars 2022

Bonjour Yal,
C'est magique, mille mercis

Bonne soirée
DE

job75 · 12 Mars 2022

Bonsoir djam28, yal,

Une autre méthode dans le fichier joint :

VB:

Private Sub Worksheet_Activate()
Dim P As Range, Q As Range, n&
With Sheets("REDCAP")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set P = .[A1].CurrentRegion.EntireRow.Cells
    Set Q = .[A:J,K:EB,EC:FZ,GA:NC,ND:PC] 'plages à adapter
End With
Application.ScreenUpdating = False
Cells.Clear 'RAZ
For n = 1 To Q.Areas.Count
    P.AutoFilter 2, P(n + 1, 2) 'filtre automatique
    Intersect(P, Q.Areas(n)).Copy Range(Q.Areas(n)(1).Address)
    P.AutoFilter
Next n
End Sub

La macro est dans le module de la feuille RESULTAT et se déclenche automatiquement quand on active cette feuille.

Nota : dans la 1ère feuille les évènements de B2 à B6 doivent correspondre aux 5 zones de la ligne 1.

Et l'évènement en B2 doit être celui qui occupe le plus de lignes.

Edit : j'ai supprimé .SpecialCells(xlCellTypeVisible) qui était inutile.

Bonne nuit.

mapomme · 13 Mars 2022

Bonjour à tous ,

Une pensée pour nos amis adeptes du MAC donc sans dictionary.
Cela doit fonctionner quelque soit la taille des différentes parties en colonne. On ne définit pas les partitions en colonne.
La feuille RECAP se met à jour à chaque fois qu'on l'active.
Le code est dans le module de la feuille RECAP.

@job75 a repéré des erreurs dans mon premier code. Je les ai corrigées. Le fichier v2 inclus les corrections.

job75 · 13 Mars 2022

Bonjour djam28, yal, mapomme,

Je viens encore de simplifier la macro du post #4 en remplaçant la 1ère zone C:J par A:J.

Bien sûr elle ne pose pas de problème sur MAC.

A+

job75 · 13 Mars 2022

@mapomme : dans la zone EC:FZ tu récupères 3 lignes alors qu'il n'y en a que 2.

Et dans la zone GA:NC tu en récupères 2 alors qu'il n'y en a qu'une.

mapomme · 13 Mars 2022

Bonjour @job75

job75 à dit:
@mapomme : dans la zone EC:FZ tu récupères 3 lignes alors qu'il n'y en a que 2.

Et dans la zone GA:NC tu en récupères 2 alors qu'il n'y en a qu'une.

Bravo et merci d'avoir repérer mes erreurs. Ce sont des erreurs grossières aussi grosses que moi.
J'en ai profité pour simplifier mon code (pas autant que le tien )
J'ai aussi remplacé le fichier de mon message #5.
Le code:

VB:

Private Sub Worksheet_Activate()
Dim F, dercol&, derlig&, n&, i&, k&, Id, nref&, nlig&, col
   Application.ScreenUpdating = False: Set F = Worksheets("REDCAP")
   If F.FilterMode Then F.ShowAllData
   derlig = F.Cells(Rows.Count, "a").End(xlUp).Row
   dercol = F.Cells(1, Columns.Count).End(xlToLeft).Column
   ReDim ref(1 To derlig, 1 To 1)
   Columns(1).Resize(, dercol).Clear
   For i = 1 To derlig
      Id = F.Cells(i, "a"): n = 0: col = "c"
      For k = 1 To nref
         If ref(k, 1) = Id Then n = k: Exit For
      Next k
      If n = 0 Then nref = nref + 1: ref(nref, 1) = Id: n = nref: nlig = nlig + 1: col = "a"
      F.Cells(i, col).Resize(, dercol - IIf(col = "c", -2, 0)).Copy
      Cells(n, col).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
   Next i
   Application.Goto Range("a1"), True
End Sub

edit: bonjour @Usine à gaz

yal · 13 Mars 2022

Bonjour
Exactement la même que la première mais sans dictionnaire

djam28 · 13 Mars 2022

job75 à dit:
Bonsoir djam28, yal,

Une autre méthode dans le fichier joint :

VB:

Private Sub Worksheet_Activate() Dim P As Range, Q As Range, n& With Sheets("REDCAP") If .FilterMode Then .ShowAllData 'si la feuille est filtrée Set P = .[A1].CurrentRegion.EntireRow.Cells Set Q = .[A:J,K:EB,EC:FZ,GA:NC,ND:PC] 'plages à adapter End With Application.ScreenUpdating = False Cells.Clear 'RAZ For n = 1 To Q.Areas.Count P.AutoFilter 2, P(n + 1, 2) 'filtre automatique Intersect(P, Q.Areas(n)).Copy Range(Q.Areas(n)(1).Address) P.AutoFilter Next n End Sub

La macro est dans le module de la feuille RESULTAT et se déclenche automatiquement quand on active cette feuille.

Nota : dans la 1ère feuille les évènements de B2 à B6 doivent correspondre aux 5 zones de la ligne 1.

Et l'évènement en B2 doit être celui qui occupe le plus de lignes.

Edit : j'ai supprimé .SpecialCells(xlCellTypeVisible) qui était inutile.

Bonne nuit.

Merci

yal à dit:
Bonjour
Exactement la même que la première mais sans dictionnaire

Merci beaucoup Yal !!
Bonne journée
DE

djam28 · 13 Mars 2022

mapomme à dit:

Bonjour @job75

Bravo et merci d'avoir repérer mes erreurs. Ce sont des erreurs grossières aussi grosses que moi.
J'en ai profité pour simplifier mon code (pas autant que le tien )
J'ai aussi remplacé le fichier de mon message #5.
Le code:

VB:

Private Sub Worksheet_Activate()
Dim F, dercol&, derlig&, n&, i&, k&, Id, nref&, nlig&, col
   Application.ScreenUpdating = False: Set F = Worksheets("REDCAP")
   If F.FilterMode Then F.ShowAllData
   derlig = F.Cells(Rows.Count, "a").End(xlUp).Row
   dercol = F.Cells(1, Columns.Count).End(xlToLeft).Column
   ReDim ref(1 To derlig, 1 To 1)
   Columns(1).Resize(, dercol).Clear
   For i = 1 To derlig
      Id = F.Cells(i, "a"): n = 0: col = "c"
      For k = 1 To nref
         If ref(k, 1) = Id Then n = k: Exit For
      Next k
      If n = 0 Then nref = nref + 1: ref(nref, 1) = Id: n = nref: nlig = nlig + 1: col = "a"
      F.Cells(i, col).Resize(, dercol - IIf(col = "c", -2, 0)).Copy
      Cells(n, col).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
   Next i
   Application.Goto Range("a1"), True
End Sub

edit: bonjour @Usine à gaz

Merci mapomme
Bonne journée
DE

djam28 · 13 Mars 2022

job75 à dit:
Bonsoir djam28, yal,

Une autre méthode dans le fichier joint :

VB:

Private Sub Worksheet_Activate() Dim P As Range, Q As Range, n& With Sheets("REDCAP") If .FilterMode Then .ShowAllData 'si la feuille est filtrée Set P = .[A1].CurrentRegion.EntireRow.Cells Set Q = .[A:J,K:EB,EC:FZ,GA:NC,ND:PC] 'plages à adapter End With Application.ScreenUpdating = False Cells.Clear 'RAZ For n = 1 To Q.Areas.Count P.AutoFilter 2, P(n + 1, 2) 'filtre automatique Intersect(P, Q.Areas(n)).Copy Range(Q.Areas(n)(1).Address) P.AutoFilter Next n End Sub

La macro est dans le module de la feuille RESULTAT et se déclenche automatiquement quand on active cette feuille.

Nota : dans la 1ère feuille les évènements de B2 à B6 doivent correspondre aux 5 zones de la ligne 1.

Et l'évènement en B2 doit être celui qui occupe le plus de lignes.

Edit : j'ai supprimé .SpecialCells(xlCellTypeVisible) qui était inutile.

Bonne nuit.

Bonjour Job75,
Merci infiniment
bonne journée
DE

job75 · 13 Mars 2022

Dans la mesure où des données limitent correctement chaque ligne cela suffit pour repérer les zones.

Dans ce fichier (2) les limites coldeb et colfin sont trouvées par la méthode Find :

VB:

Private Sub Worksheet_Activate()
Dim P As Range, Q As Range, nzone, n&, coldeb%, colfin%
With Sheets("REDCAP")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set P = .[A1].CurrentRegion.EntireRow.Cells
    Set Q = P.Offset(1).Resize(P.Rows.Count - 1)
End With
Application.ScreenUpdating = False
Cells.Clear 'RAZ
nzone = Application.CountIf(P.Columns(1), Q(1))
For n = 1 To nzone
    P.AutoFilter 2, Q(n, 2) 'filtre automatique
    If n = 1 Then coldeb = 1 Else coldeb = Q.Find("*", Q(Q.Rows.Count, 2), xlValues, , xlByColumns, xlNext).Column
    If n = nzone Then colfin = P(1, Columns.Count).End(xlToLeft).Column Else colfin = Q.Find("*", Q(1), , , , xlPrevious).Column
    P.Columns(coldeb).Resize(, colfin - coldeb + 1).Copy Range(P(1, coldeb).Address)
    P.AutoFilter
Next n
End Sub

XL 2010 transposer plusieurs lignes-même ID

djam28

XLDnaute Occasionnel

Pièces jointes

djam28

yal

XLDnaute Occasionnel

Pièces jointes

djam28

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

yal

XLDnaute Occasionnel

Pièces jointes

djam28

XLDnaute Occasionnel

djam28

XLDnaute Occasionnel

djam28

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires