XL 2016 Relevé de la première et dernière données par jour dans une BDD

Matthias A

XLDnaute Nouveau
Bonjour à tous,

Je sèche sur un travail.

J'ai une base de donnée comportant l'ensemble des actes par praticien sur une période donnée. J'ai donc un certain nombre de lignes par jour pour différents praticien. Je souhaite relever l'heure du premier et du dernier acte par jour et par praticien pour calculer l'heure moyenne de début et de fin de vacation. Je vous joins une capture d'écran de ma base de donnée pour explicité le propos.

Dans les faits je n'ai pas envie de balayer une base de donnée de plusieurs dizaine de millier de lignes pour relever les informations une à une. Je pense qu'il existe un moyen plus simple de faire cela mais je touche à la limite de mes compétences.

En espérant que l'un d'entre vous aura une idée pour me permettre d'apprendre.

Bien cordialement

Matthias
 

Pièces jointes

  • Capture.PNG
    Capture.PNG
    71.9 KB · Affichages: 36
  • test.xlsx
    17.5 KB · Affichages: 3
Dernière édition:

job75

XLDnaute Barbatruc
Voyez le fichier joint et cette macro dans le code de la feuille "Moyennes" :
VB:
Private Sub Worksheet_Activate()
Dim d As Object, dmin As Object, dmax As Object, tablo, i&, x$, h#, resu(), a, aa, b, c, nom$, n&, nn&, j&
Set d = CreateObject("Scripting.Dictionary")
Set dmin = CreateObject("Scripting.Dictionary")
Set dmax = CreateObject("Scripting.Dictionary")
tablo = Sheets("BDD").[A1].CurrentRegion.Resize(, 5)
'---analyse du tableau---
For i = 2 To UBound(tablo)
    d(tablo(i, 3)) = ""
    x = tablo(i, 2) & " " & tablo(i, 3)
    h = CDbl(CDate(tablo(i, 5)))
    If dmin.exists(x) Then
        If h < dmin(x) Then dmin(x) = h
        If h > dmax(x) Then dmax(x) = h
    Else
        dmin(x) = h
        dmax(x) = h
    End If
Next
'---tableau des résultats---
n = d.Count
If n Then
    ReDim resu(n - 1, 2) 'base 0
    a = d.keys: aa = dmin.keys: b = dmin.items: c = dmax.items
    For i = 0 To UBound(a)
        nom = a(i)
        resu(i, 0) = nom
        nn = 0
        For j = 0 To UBound(aa)
            If Split(aa(j))(1) = nom Then
                nn = nn + 1
                resu(i, 1) = resu(i, 1) + b(j)
                resu(i, 2) = resu(i, 2) + c(j)
            End If
        Next j
        resu(i, 1) = resu(i, 1) / nn 'moyenne des minima
        resu(i, 2) = resu(i, 2) / nn 'moyenne des maxima
    Next i
End If
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de restitution, à adapter
    If n Then .Resize(n, 3) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
End Sub
Elle se déclenche quand on active la feuille.

Les résultats sont les mêmes que ceux de chris sauf :

- pour ceux de CHAFRA

- pour ceux de CHAREM qui n'existe pas chez chris.

A+
 

Pièces jointes

  • test(1).xlsm
    29.3 KB · Affichages: 4

Matthias A

XLDnaute Nouveau
Voyez le fichier joint et cette macro dans le code de la feuille "Moyennes" :
VB:
Private Sub Worksheet_Activate()
Dim d As Object, dmin As Object, dmax As Object, tablo, i&, x$, h#, resu(), a, aa, b, c, nom$, n&, nn&, j&
Set d = CreateObject("Scripting.Dictionary")
Set dmin = CreateObject("Scripting.Dictionary")
Set dmax = CreateObject("Scripting.Dictionary")
tablo = Sheets("BDD").[A1].CurrentRegion.Resize(, 5)
'---analyse du tableau---
For i = 2 To UBound(tablo)
    d(tablo(i, 3)) = ""
    x = tablo(i, 2) & " " & tablo(i, 3)
    h = CDbl(CDate(tablo(i, 5)))
    If dmin.exists(x) Then
        If h < dmin(x) Then dmin(x) = h
        If h > dmax(x) Then dmax(x) = h
    Else
        dmin(x) = h
        dmax(x) = h
    End If
Next
'---tableau des résultats---
n = d.Count
If n Then
    ReDim resu(n - 1, 2) 'base 0
    a = d.keys: aa = dmin.keys: b = dmin.items: c = dmax.items
    For i = 0 To UBound(a)
        nom = a(i)
        resu(i, 0) = nom
        nn = 0
        For j = 0 To UBound(aa)
            If Split(aa(j))(1) = nom Then
                nn = nn + 1
                resu(i, 1) = resu(i, 1) + b(j)
                resu(i, 2) = resu(i, 2) + c(j)
            End If
        Next j
        resu(i, 1) = resu(i, 1) / nn 'moyenne des minima
        resu(i, 2) = resu(i, 2) / nn 'moyenne des maxima
    Next i
End If
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de restitution, à adapter
    If n Then .Resize(n, 3) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
End Sub
Elle se déclenche quand on active la feuille.

Les résultats sont les mêmes que ceux de chris sauf :

- pour ceux de CHAFRA

- pour ceux de CHAREM qui n'existe pas chez chris.

A+
Merci !!
 

Matthias A

XLDnaute Nouveau
RE


J'y ai en tout et pour tout effectué 4 manipulations très simples
  1. une modification du typage de la colonne date (pas nécessaire ici, plus une habitude...)
  2. un regroupement avec calcul des min et max de l'heure d'arrivée par date et personne
  3. un regroupement du résultat obtenu avec calcul des moyennes des Min et Max
  4. un tri (pas obligatoire)
cela en utilisant les options du ruban et des boites de dialogue, donc très facilement
A noter que PowerQuery a considéré automatiquement les heures pourtant sous forme de texte comme des heures
Merci Chris j'ai réussi a reproduire votre démarche sur l'ensemble de ma base c'est top comme outil.

J'aurais une petite question supplémentaire.

Sauriez vous si à la suite de ces retraitements je peux rajouter une colonne qui dénombrerait le nombre de vacation par praticien.
L'idée est renvoyer le nombre de dates différentes de la colonne "date d'arrivée" par praticien. Mais la je sèche...

Je vous joins mon fichier qui à évolué.
 

Pièces jointes

  • BDD imagerie partage.xlsx
    947.2 KB · Affichages: 3

chris

XLDnaute Barbatruc
Bonjour

Il faut un autre regroupement
Voici avec 2 exemples :
  • l'un en 1 requête,
  • l'autre qui décompose le même approche en 4 requêtes pour comprendre la logique
 

Pièces jointes

  • BDD imagerie partage_PQ.xlsx
    961.2 KB · Affichages: 4
Dernière édition:

Discussions similaires

Réponses
16
Affichages
1 K