Bonjour, je dispose d’une grande base de données portant sur des prescriptions de médicaments et je souhaiterai que les prescriptions émanant d’un même médecin soit rassemblée sur une même ligne plutôt que sur des lignes distinctes. Actuellement, chaque médicament prescrit par un même médecin est présenté sur une ligne distincte, fournissant des infos sur le type de médicaments (G), le nombre de doses standards délivrées (H), et le nombre de patients concernés (I). La colonne pseudo est celle qui permet d’identifier qu’il s’agit d’un même patient. Les autres colonnes donnent des infos sur le médecin (province, sexe, age, type de prescripteur).
J’ai une requête similaire pour la base de données qui porte cette fois sur les patients. La variable qui permet d’identifier les patients est la variable “Pseudonyme”. Je souhaiterais donc également que les lignes correspondant à un même patient (cela n’arrive qui si un patient s’est vu prescrire plusieurs médicaments) soient fusionnées sur une même ligne.
Un grand merci, mais ça ne semble pas marcher. J’ai des messages d’erreur par rapport aux fonctions. Peut-être parce que je tourne avec Office petite entreprise 2013 :-/ Du coup, s’il vous est possible de transposer en macro, ce serait top ! Et si jamais vous avez le temps et l’envie, j’ai élargi ma demande à une deuxième base de données, qui porte cette fois sur les patients. J’aurai bien fait cela manuellement mais il y a bcp trop d’entrée (plus d’un million pour les patients). Un grand merci !
Ca marche merci, il faudrait juste que les colonnes ddd et COUNT_DISTINCT_of_numano_benefic soient également placées à côté de chacun des médicaments car ces sont reliées: code atc correspond au médicament, ddd au nombre de doses prescrites, et Count_distinct_… le nombre de patients concernés. Ce sont donc ces 3 variables qu’il faut pouvoir replacer sur une seule ligne pour chaque médecin. Désolé d’avoir manqué de précision.
Sub test()
Dim Dico As Object, C As Range, I As Long
Set Dico = CreateObject("Scripting.Dictionary")
For Each C In Range("B2", Cells(Rows.Count, 2).End(xlUp))
If Not Dico.exists(C.Value) Then
Dico.Add C.Value, C.Value
End If
Next C
For Each Item In Dico.items
I = 1
l = l + 1
Cells(l, 12) = Item
For Each C In Range("B2", Cells(Rows.Count, 2).End(xlUp))
If C = Item Then
Cells(l, 12 + I) = C.Offset(, 5)
I = I + 1
Cells(l, 12 + I) = C.Offset(, 6)
I = I + 1
Cells(l, 12 + I) = C.Offset(, 7)
I = I + 1
End If
Next C
Next Item
End Sub
Les résultats se trouvent à partir de L1. Si tu les veux ailleurs, dis-le.
Sub test()
Dim Dico As Object, C As Range, I As Long, L As Long, Cellule As Range
Set Dico = CreateObject("Scripting.Dictionary")
For Each C In Range("B2", Cells(Rows.Count, 2).End(xlUp))
If Not Dico.exists(C.Value) Then
Dico.Add C.Value, C.Value
End If
Next C
L = 1
Set Cellule = Cells(L, 12) 'on dit une fois la cellule "TopLeft" de votre plage et le reste est relative à cette cellule
Cellule.Resize(20, 20).ClearContents 'RAZ 20x20 cellules en dessous et à droit
For Each Item In Dico.items
I = 2
Cellule.Cells(L, 1).Value = Item
For Each C In Range("B2", Cells(Rows.Count, 2).End(xlUp))
If C = Item Then
Cellule.Cells(L, I).Resize(, 3).Value2 = C.Offset(, 5).Resize(, 3).Value2 'les 3 en même temps
I = I + 3
End If
Next C
L = L + 1
Next Item
End Sub
Bonjour un grand merci ca fonctionne parfaitement! La macro a pris plus de 2 heures pour faire le travail de transcription Si vous avez le temps à l’occase, j’ai une demande similaire pour la base de données patients ci-dessuss, où je souhaite également que les prescriptions multiples à un même patient soient exprimées sur une même ligne. La variable pseudonyme est celle qui permet d’identifier les patients, et les variables “code_atc”, “Sum_of_ddd” et “DDD_Recod” sont celles que je souhaite voir rassembler sur une même ligne. Un grand merci !
Sub testM()
Dim Dico As Object, C As Range, I As Long, TblMed As Variant, Tbl As Variant, Tbl1(), Result(), L As Long, IT As Long
On Error Resume Next
Range("L1").Resize(Application.CountA([L:L]), Cells.Find("*", , , , xlByColumns, xlPrevious).Column - 11).ClearContents
On Error GoTo 0
Set Dico = CreateObject("Scripting.Dictionary")
Tbl = Application.Transpose(Range("B2", Cells(Rows.Count, 2).End(xlUp)))
TblMed = Range("G2", Cells(Rows.Count, 7).End(xlUp)).Resize(, 3)
For I = 1 To UBound(Tbl)
If Not Dico.exists(Tbl(I)) Then
Dico.Add Tbl(I), Tbl(I)
End If
Next I
ReDim Tbl1(Dico.Count - 1)
I = -1
For Each Item In Dico.items
I = I + 1
Tbl1(I) = Item
Next Item
[L1].Resize(Dico.Count) = Application.Transpose(Tbl1)
IT = 0
For Each Item In Dico.items
IT = IT + 1
L = -1
For I = 1 To UBound(Tbl)
If Tbl(I) = Item Then
L = L + 1
ReDim Preserve Result(L)
Result(L) = TblMed(I, 1)
L = L + 1
ReDim Preserve Result(L)
Result(L) = TblMed(I, 2)
L = L + 1
ReDim Preserve Result(L)
Result(L) = TblMed(I, 3)
End If
Next I
Cells(IT, 13).Resize(, UBound(Result) + 1) = Result
Erase Result
Next Item
End Sub
Un grand merci pour votre aide à tous les deux. Pour les prescripteurs, c’est nickel. Je vais tester l’extrapolation de la macro à la deuxième base de données et je reviens vers vous prochainement.
le but, pour gagner du temps, est de minimaliser les interactions avec la feuille, donc le nombre de “Read” et “Write”. Cela peut commencer avec un “application.screenupating=false” pour bloquer la mise à jour de l’écran. Bon, vous écrivez une ligne par médicin, je l’ai modifié un peu dans “TestM2” de manière qu’on écrit tous les médicins ensemble au bout de la macro. Je fais cela 100 fois pour votre et ma macro dans la macro M_test, et comme les données sont pour le moment presque 1.000 lignes, cela vous donne une indication pour une feuille de 100.000 lignes. Votre macro prend 10 sec et la mienne presque 9 sec, environ 15-20% plus vite, mais c’est ridicule, 1 sec pour 100.000 lignes … . Ici, la macro ne fait pas grand chose, souvent les écarts sont plus grandes.
