XL 2010 transposer plusieurs lignes-même ID

D

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: 14
Trier par date Trier par votes
job75

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:
Vote positif 0 Vote négatif
mapomme

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:
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
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.
Cliquez pour agrandir...
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:
Vote positif 0 Vote négatif
D

djam28

XLDnaute Occasionnel
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.
Cliquez pour agrandir...

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.
Cliquez pour agrandir...
Merci
yal à dit:
Bonjour
Exactement la même que la première mais sans dictionnaire
Cliquez pour agrandir...
Merci beaucoup Yal !!
Bonne journée
DE
 
Vote positif 0 Vote négatif
D

djam28

XLDnaute Occasionnel
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
Cliquez pour agrandir...
Merci mapomme
Bonne journée
DE
 
Vote positif 0 Vote négatif
D

djam28

XLDnaute Occasionnel
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.
Cliquez pour agrandir...
Bonjour Job75,
Merci infiniment
bonne journée
DE
 
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2021 recherche doublons dans colonne puis suppression des lignes
Réponses
5
Affichages
518
ftpo69
F
A
  • Question
XL pour MAC Peut on mettre plusieurs données de différentes lignes sur une seule ?
Réponses
5
Affichages
864
chris
chris
C
  • Question
XL 2021 Créer une vue filtrée sur plusieurs lignes
Réponses
1
Affichages
439
djidji59430
djidji59430
T
  • Question
XL 2010 Supprimer les lignes en doubles (multi critères)
2
Réponses
18
Affichages
2 K
oguruma
oguruma
D
  • Question
XL 2019 Concaténer plusieurs lignes à partir d'une référence en doublon
Réponses
5
Affichages
716
vgendron
vgendron
K
  • Question
Microsoft 365 Formule INDEX/EQUIV avec plusieurs valeurs pour une même en-tête
Réponses
2
Affichages
2 K
KLfy
K
D
  • Question
XL 2010 fusionner 2 tableaux avec même id -macro
Réponses
11
Affichages
2 K
djam28
D
D
  • Résolu(e)
XL 2010 Doublons sur une ligne
Réponses
2
Affichages
510
djam28
D
C
  • Question
XL 2019 Tableau- creation de lignes: probleme de hauteur de lignes
Réponses
6
Affichages
599
Cheyenne_2021
C
D
  • Question
XL 2010 Fusion 2 tableaux avec plusieurs doublons macro
Réponses
3
Affichages
882
cp4
cp4

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 63 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 097
Messages
2 116 186
Membres
112 679
dernier inscrit
Yupanki