Calculer la durée totale pour 3 conditions

[apt]

Bonjour à tous,

Pour calculer la durée totale en VBA pour chaque site dans un BDD, avec trois conditions :

- Nom du site

- Mois choisi depuis une liste de validation en H2

- Cause choisie depuis une liste de validation en I2

J'ai essayé d'adapter un code que j'avais sous la main, mais je n'ai pas encore réussi.

Dans le fichier exemple joint, j'ai commenté quelque ligne pour aider à faire comprendre le fonctionnement du code.

Je suis prés pour plus d'explications.

Merci d’avance.

 

[Compte Supprimé 979]

Re : Calculer la durée totale pour 3 conditions

Bonjour Apt,

Avec une petite fonction personnalisée 😉

A toi de voir si cela te convient

A+

 

[Gareth]

Re : Calculer la durée totale pour 3 conditions

Bonjour à tous,

Ci-joint une autre solution sans macro utilisant les TCD.
J'ai modifié la formule dans la colonne F permettant de s'affranchir d'une fonction personalisée.

Salutations

 

[apt]

Re : Calculer la durée totale pour 3 conditions

Bonjour Bruno45,

J'ai fait des essais mais ça ne donne pas encore le résultat voulu :

Prenons l'exemple du site : ADB

Je devrais avoir le résultat suivant :

00 jours(s) 27 heure(s) 09 minute(s)

Au lieu de celui-ci :

00 jour(s) 11 heure(s) 28 minute(s)

Parce qu’il y a une durée qui s’étend entre Juillet-Août, dans cette ligne :

ADB 30/07/2012 13:57 01/08/2012 15:41 02 jour 01h:44mn CS

La durée totale en minutes dans ce cas est de : 2984 minutes

Si on ne calcul que celle commençant par le 01/08/2012 00:00 est le 01/08/2012 15:41 on trouvera : 941 minutes

d'ou le résultat :

00 jours(s) 27 heure(s) 09 minute(s)

En plus je souhaiterais avoir un code pour extraire les noms des sites dans la colonne K, concernés par le mois et la cause choisis.

Merci.

 

[apt]

Re : Calculer la durée totale pour 3 conditions

Bonjour Gareth,

Merci pour le TCD (ça me fait tourner la tête les TCDs 🙄)

Mais si on prend toujours le cas du site ADB, normalement on devra trouver 1629 minutes au lieu de 688 minutes, selon l'explication fourni en haut.

 

[Gareth]

Re : Calculer la durée totale pour 3 conditions

Re,

Ci-joint un exemple utilisant toujours les TCD.
Mais le TCD fait référence à une base de donnée située sur la Feuil2.
Cette base est nommée MaZone et fait référence à un nom variable (Qui correspond à l'ensemble des données CTRL + F3 pour voir).


La macro tronçonne la base par mois.
Voir exemple pour ADB échelonné sur Juillet et Aout.

 

[apt]

Re : Calculer la durée totale pour 3 conditions

Bonjour Gareth,

Ci-joint un exemple utilisant toujours les TCD

J'aurais aimé aussi avoir du code vba que je comprend mieux que les TCDs ...

Merci pour la réponse.

Mais quand je veux avoir la durée totale pour le cas ADB en jours, heures, minutes, j'ai

Selon la deuxième feuille, dans le cas ADB :

ADB 30/07/2012 13:57 01/08/2012 15:41 02 jour 01h:44mn CS 2984

On devra le remplacer par :

ADB 01/08/2012 00:00 01/08/2012 15:41 00 jour 15h:41mn CS 941

Et non pas par :

ADB 30/07/2012 13:57 01/08/2012 00:00 01 jour 10h:03mn CS 2043

Dans ce cas là, c'est la première date de début qui devra être remplacé par le 01/08/2012 00:00 et non pas la date de fin.

😉

 

[Gareth]

Re : Calculer la durée totale pour 3 conditions

Bonjour,

Ma macro recopie la base de la Feuil1 dans la Feuil2 en "découpant" les lignes pour lesquelles les durées sont étalées sur plusieurs mois.
En Feuil1 on a :
ADB 30/07/2012 13:57 01/08/2012 15:41 02 jour 01h:44mn CS 2984
ADB 09/08/2012 00:31 09/08/2012 11:59 00 jour 11h:28mn CS 688

Qui devient en Feuil2 :
ADB 30/07/2012 13:57 01/08/2012 00:00 01 jour 10h:03mn CS 2043
ADB 01/08/2012 00:00 01/08/2012 15:41 00 jour 15h:41mn CS 941
ADB 09/08/2012 00:31 09/08/2012 11:59 00 jour 11h:28mn CS 688

=> 2984 = 2043 + 941
ADB pour Aout = 941 + 688 = 1629

Le fichier ainsi obtenu permet de faire une requete par mois.

Explique-moi quel résultat tu souhaites au final.
On peut tout faire par Macro...

 

[apt]

Re : Calculer la durée totale pour 3 conditions

Bonsoir Gareth, le fil

Ma macro recopie la base de la Feuil1 dans la Feuil2 en "découpant" les lignes pour lesquelles les durées sont étalées sur plusieurs mois.

J'ai compris maintenant. Merci.

La base en Feuil1, contient les arrêts pour tous les mois de l'année.

Ne peut-on pas recopier et traiter que les lignes des dates du mois choisi ?

On peut tout faire par Macro...

Génial !!

Donc voila un essai par VBA :

 Option Explicit

Sub CalculeDureeTotalSite()
    Const Cible As String = "K1"
    Dim Str As String, Cause As String, Res()
    Dim LastLig As Long, i As Long, n As Long
    Dim j As Integer
    Dim MonDico As New Scripting.Dictionary
    Dim Tb
    Dim M1 As Integer, M2 As Integer
    Dim MoisNum As Integer, Mn As Integer

    With Feuil1
        LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
        Tb = .Range("A2:F" & LastLig)
        For i = 1 To UBound(Tb, 1)

            M1 = Format(Tb(i, 2), "mm")
            M2 = Format(Tb(i, 3), "mm")
            MoisNum = Application.Match(Range("Mois"), Range("ListeMois"), 0)
            [H3].Value = MoisNum
            Cause = Tb(i, 5)
            Application.ScreenUpdating = False

            If (M1 = MoisNum Or M2 = MoisNum) And Cause = "CS" Then
                Str = Tb(i, 1)
                'Pour les sites
                If Not MonDico.Exists(Str) Then
                    MonDico.Add Str, Cause
                Else
                    MonDico(Str) = MonDico(Str) & "," & Cause
                End If
                 End If
        Next i

                n = MonDico.Count
        If n > 0 Then
       
            ReDim Res(1 To n + 1, 1)
            Res(1, 1) = "Site"
      
            For i = 0 To n - 1
                Res(i + 2, 1) = MonDico.Keys(i)
     
                MsgBox "Res(" & i & " + 2, 1) : " & Res(i + 2, 1)
            Next i
            Set MonDico = Nothing
            .Range(Cible).Resize(n + 1) = Res
            .Range(Cible).Resize(n + 1).Sort Key1:=.Range(Cible), Order1:=xlAscending, Header:=xlYes
        End If
   End With
    
    '-- Ajout de la formule qui calcul les durées totales pour chaque site
    'AjoutFormule
    
    Application.ScreenUpdating = False
End Sub
Sub AjoutFormule()
    Dim DerLigne As Long
    [L2].FormulaArray = "=SUM((MONTH($B$2:$B$94)<=$H$3)*(MONTH($C$2:$C$94)>=$H$3)*($E$2:$E$94=Cause)" & _
                        "*($A$2:$A$94=K2)*((IF($C$2:$C$94<=DATE(2012,$H$3+1,0),$C$2:$C$94,DATE(2012,$H$3+1,0)))" & _
                        "-(IF($B$2:$B$94>DATE(2012,$H$3,1),$B$2:$B$94,DATE(2012,$H$3,1)))))"
    DerLigne = Cells(Rows.Count, 11).End(xlUp).Row
    [L2].AutoFill Range([L2], Cells(DerLigne, 12))
End Sub

[XL-2007] Extraction de données avec calcul - Forum des professionnels en informatique

 

[apt]

Re : Calculer la durée totale pour 3 conditions

Bonjour à tous,

Un code qui fonctionne très bien :

Option Explicit
 
Sub CalculeDureeTotalSite()
Const Cible As String = "K2"
Dim LastLig As Long, i As Long, n As Long, Duree As Double
Dim M1 As Byte, M2 As Byte, MoisNum As Byte
Dim MonDico As New Scripting.Dictionary
Dim Str As String, LaCause As String
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range(Cible).Resize(LastLig, 2).ClearContents
    Tb = .Range("A2:E" & LastLig)
    LaCause = .[Cause]
    MoisNum = Application.Match(.[Mois], .[ListeMois], 0)
    For i = 1 To UBound(Tb, 1)
        If Tb(i, 5) = LaCause Then
            M1 = Month(Tb(i, 2))
            M2 = Month(Tb(i, 3))
            If Entre(MoisNum, M1, M2) Then
                If M1 < MoisNum Then Tb(i, 2) = DebMois(Tb(i, 2), MoisNum)
                If M2 > MoisNum Then Tb(i, 3) = FinMois(Tb(i, 3), MoisNum)
                Duree = Tb(i, 3) - Tb(i, 2)
                Str = Tb(i, 1)
                If Not MonDico.Exists(Str) Then
                    MonDico.Add Str, Duree
                Else
                    MonDico(Str) = MonDico(Str) + Duree
                End If
            End If
        End If
    Next i
 
    n = MonDico.Count
    If n > 0 Then
        ReDim Res(1 To n, 1 To 2)
        For i = 0 To n - 1
            Res(i + 1, 1) = MonDico.Keys(i)
            Res(i + 1, 2) = MonDico.Items(i)
        Next i
        Set MonDico = Nothing
        .Range(Cible).Resize(n, 2) = Res
        .Range(Cible).Offset(0, 1).Resize(n, 1).NumberFormat = "dd ""jour(s)"" hh"" heure(s) ""mm"" minute(s)"""
        .Range(Cible).Resize(n, 2).Sort Key1:=.Range(Cible), Order1:=xlAscending, Header:=xlNo
    End If
End With
End Sub
 
Private Function Entre(ByVal M As Byte, ByVal Mi As Byte, ByVal Mf As Byte) As Boolean
 
Entre = M >= Mi And M <= Mf
End Function
 
Private Function DebMois(ByVal Dte As Long, ByVal M As Byte) As Long
 
DebMois = DateSerial(Year(Dte), M, 1)
End Function
 
Private Function FinMois(ByVal Dte As Long, ByVal M As Byte) As Double
 
FinMois = DateSerial(Year(Dte), M + 1, 1) - 1 / 1440
End Function

Merci pour tous.