XL 2010 transposer plusieurs lignes-même ID

djam28

XLDnaute Occasionnel
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
 

Pièces jointes

  • REDCAP TEST.xlsx
    23.3 KB · Affichages: 13

job75

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

Pièces jointes

  • REDCAP TEST(1).xlsm
    28.3 KB · Affichages: 1
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
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.
 

Pièces jointes

  • djam28- Recap- v2.xlsm
    28.1 KB · Affichages: 2
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @job75 :)
@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
 

Pièces jointes

  • djam28- Recap- v2.xlsm
    28.1 KB · Affichages: 7
Dernière édition:

djam28

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

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
Bonjour
Exactement la même que la première mais sans dictionnaire
Merci beaucoup Yal !!
Bonne journée
DE
 

djam28

XLDnaute Occasionnel
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

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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
 

Pièces jointes

  • REDCAP TEST(2).xlsm
    29.1 KB · Affichages: 1

Discussions similaires

Réponses
2
Affichages
305

Statistiques des forums

Discussions
300 874
Messages
1 987 969
Membres
210 036
dernier inscrit
Vincent97438