Compter le nombre de redondances

Version imprimable

Bonjour à tous,

Dans un précédent code de mercatog :

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

Code:

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.

:P

17/09/2012, 15h01
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.
17/09/2012, 15h59
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

1 pièce(s) jointe(s)

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:

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

Testé sur le fichier de l'autre sujet

Code:

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.

18/09/2012, 00h49
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))
18/09/2012, 20h20
mercatog

Effectivement il y a erreur quand le séparateur décimal est la virgule

Remplace la ligne en question par

Code:

Temps = Evaluate(Replace(MonDico.Items(i), ",", "."))

PS: Le debug.print juste en dessus était fait exprès.
18/09/2012, 23h46
apt

Bonsoir à tous,

Merci mercatog de la rectification. Ça marche très bien

Daniel :: En voulant trier le tableau résultant, j'ai ajouté cette ligne :

Code:

.Cells(.Cells(1, 11), .Cells(.Rows.Count, 13).End(xlUp)).Sort key1:=.Cells(1, 11), Order1:=xlAscending, Header:=xlYes

qui me déclenche une erreur d'incompatibilité de type :aie:
18/09/2012, 23h49
mercatog

Insomnie oblige, je répondrai à la place de Daniel

Code:

.Range(.Cells(1, 11), .Cells(.Rows.Count, 13).End(xlUp)).Sort key1:=.Cells(1, 11), Order1:=xlAscending, Header:=xlYes

La collection Cells reçoit un n° de ligne x et un n° de colonne y en paramètres: Cells(x, y)
19/09/2012, 00h16
apt

Salut mercatog,

Merci pour ta réponse, mais il n'y a pas de tri 8O

Parce que la plage désignée par :

Code:

.Range(.Cells(1, 11), .Cells(.Rows.Count, 13).End(xlUp)).Address

Représente $K$1:$M$1 c'est tout au lieu de $K$1:$M$30 attendue :calim2:
19/09/2012, 09h25
mercatog

Ta colonne M est elles vide?
Et comme ceci?

Code:

.Range("K1:M"& .Cells(.Rows.Count, 11).End(xlUp).row).Sort key1:=.Range("K1"), Order1:=xlAscending, Header:=xlYes
19/09/2012, 10h52
Daniel.C

Citation:

Code:

.Cells(.Cells(1, 11), .Cells(.Rows.Count, 13).End(xlUp)).Sort key1:=.Cells(1, 11), Order1:=xlAscending, Header:=xlYes

La syntaxe est incorrecte. Il faut mettre :

Code:

.Range(.Cells(1, 11), .Cells(.Rows.Count, 13).End(xlUp)).Sort key1:=.Cells(1, 11), Order1:=xlAscending, Header:=xlYes

Bonsoir mercatog, Daniel,

Vos deux solutions fonctionnent très bien.

Seulement, il faut les mettre après la désactivation du filtre automatique :

Code:

.AutoFilterMode = False

Sinon pas de tri :mrgreen:
Code:

1 2 3 4 5 6 7 .AutoFilterMode = False .Range(.Cells(1, 11), .Cells(.Rows.Count, 13).End(xlUp)) _ .Sort key1:=.Cells(1, 11), Order1:=xlAscending, Header:=xlYes '-- Ou bien .Range("K1:M" & .Cells(.Rows.Count, 11).End(xlUp).Row) _ .Sort key1:=.Range("K1"), Order1:=xlAscending, Header:=xlYes .[N:O].ClearContents
Merci infiniment pour votre patience.

Salutations :P