Discussion :

[apt]

Bonjour à tous,

Dans un précédent code de mercatog :

http://www.developpez.net/forums/d12...onnees-calcul/

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Sub CalculeDureeTotalSite()
    Const Cible As String = "A10"
    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
        Feuil9.Range(Cible).Resize(LastLig, 2).ClearContents
        Tb = .Range("A8:F" & LastLig)
        LaCause = .[Cause]
        MoisNum = Application.Match(.[Mois], .[ListeMois], 0)
        'MsgBox "MoisNum : " & MoisNum
        For i = 1 To UBound(Tb, 1)
        'MsgBox "LaCause : " & Tb(i, 6)
            If Tb(i, 6) = LaCause Then
                M1 = Month(Tb(i, 3))
                M2 = Month(Tb(i, 4))
                'MsgBox "M1 : " & M1 & vbCrLf & _
                '"M2 : " & M2
                If Entre(MoisNum, M1, M2) Then
                    If M1 < MoisNum Then Tb(i, 3) = DebMois(Tb(i, 3), MoisNum)
                    If M2 > MoisNum Then Tb(i, 4) = FinMois(Tb(i, 4), MoisNum)
                    Duree = Tb(i, 4) - Tb(i, 3)
                    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
        MsgBox "N :" & n
        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
            With Feuil9
                .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 With
        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

Je parvenais à calculer la durée totale de chaque site pour une cause spécifiée.

Maintenant, je souhaiterais avoir le nombre de redondance de cette même cause pour chaque site pendant la durée calculée.

Merci d'avance.

[Daniel.C]

Bonjour,

Avant qu'on ne s'embarque dans des quiproquos, donne deux trois résultats attendus d'après le classeur ayant servi au fil précédent.

[apt]

Bonsoir Daniel,

Par exemple :

Site ;Nbr de redondance ;Durée total de l'arrêt ;Durée (Min)
ADB ;2 ;01 jours 03 heures 09 minutes ;1629
AHD ;3 ;00 jours 05 heures 06 minutes ;306
BGR ;2 ;00 jours 06 heures 57 minutes ;417
CHM ;2 ;00 jours 00 heures 59 minutes ;59
DHM ;1 ;00 jours 00 heures 57 minutes ;57

[Daniel.C]

Regarde la macro Test dans le classeur joint. J'ai un désaccord sur ADB. Vérifie les dates, comme on a travaillé sur plusieurs classeurs. Les résultata sont en colonne M :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub test()
    Dim Dico As Object, C As Range, Mois As Integer, Plage As Range, Plage1 As Range
    ligne = 1
    Set Dico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1")
        Mois = Application.Match(.[G2], .[Q:Q], 0)
        For Each C In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
            If C.Offset(, 2) >= DateSerial(2012, Mois, 1) Then
                .Cells(C.Row, 14) = Application.Max(DateSerial(2012, Mois, 1), C.Offset(, 1))
            End If
            If C.Offset(, 2) <= DateSerial(2012, Mois + 1, 1) Then
                .Cells(C.Row, 15) = Application.Min(DateSerial(2012, Mois + 1, 1), C.Offset(, 2))
            End If
            If Not Dico.exists(C.Value) Then
                Dico.Add C.Value, C.Value
            End If
        Next C
        Set Plage = .Range(.[A1], Cells(.Rows.Count, 1).End(xlUp)).Resize(, 15)
        For Each Item In Dico.items
            .AutoFilterMode = False
            Set Plage1 = Plage
            Plage1.AutoFilter 1, Item
            Plage1.AutoFilter 5, .[H2]
            Plage1.AutoFilter 14, ">=" & Format(DateSerial(2012, Mois, 1), "mm/dd/yyyy")
            Plage1.AutoFilter 15, "<=" & Format(DateSerial(2012, Mois + 1, 1), "mm/dd/yyyy")
            If Application.Subtotal(103, .[A:A]) > 1 Then
                ligne = ligne + 1
                .Cells(ligne, 11) = Item
                .Cells(ligne, 12) = Application.Subtotal(109, .[O:O]) - Application.Subtotal(109, .[N:N])
                .Cells(ligne, 13) = Application.Subtotal(103, .[O:O])
            End If
        Next Item
        .AutoFilterMode = False
        .[N:O].ClearContents
    End With
End Sub

[mercatog]

Testé sur le fichier de l'autre sujet

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Option Explicit
 
Sub CalculeDureeTotalSite()
Const Cible As String = "K2"
Dim Str As String, LaCause As String, Duree As String
Dim M1 As Byte, M2 As Byte, MoisNum As Byte
Dim LastLig As Long, i As Long, n As Long
Dim MonDico As New Scripting.Dictionary
Dim Temps As Double
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil2
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range(Cible).Resize(LastLig, 4).ClearContents
    Tb = .Range("A2:F" & 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 = CStr(CDbl(Tb(i, 3)) - CDbl(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 4)
        For i = 0 To n - 1
        Debug.Print i, MonDico.Keys(i), MonDico.Items(i)
            Res(i + 1, 1) = MonDico.Keys(i)
            Tb = Split(MonDico.Items(i), "+")
            Res(i + 1, 2) = UBound(Tb) + 1
            Erase Tb
            Temps = Evaluate(MonDico.Items(i))
            Res(i + 1, 3) = Temps
            Res(i + 1, 4) = Round(1440 * Temps)
        Next i
        Set MonDico = Nothing
        .Range(Cible).Resize(n, 4) = Res
        .Range(Cible).Offset(0, 2).Resize(n, 1).NumberFormat = "dd ""jour(s)"" hh"" heure(s) ""mm"" minute(s)"""
        .Range(Cible).Resize(n, 4).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

PS: Attention à la déclaration de la variable Duree. Elle est désormais As String et non plus As Double. Vaut mieux prévenir à l'avance.

[apt]

Bonjour Daniel, mercatog,

Merci pour vos réponses.

Daniel :: Pour les premiers tests, ça marche

Et tu as raison pour le cas ADB.

Je vais continuer à tester !

mercatog :: Ca donne une erreur d'incompatibilité de type dans cette ligne :

Temps = Evaluate(MonDico.Items(i))