Extraction de données avec calcul

**apt** · 09/09/2012, 10h35

Bonjour à tous,

~~Dans le fichier joint,~~ j'aimerais extraire des données selon deux critères en utilisant les filtre automatique ou élaboré :

- Nom de site

- Mois choisi en F2

Tout en calculant la durée totale de chaque site pendant la période allant de 01/08/2012 00:00 au 01/09/2009 00:00

J'ai essayé d'appliquer un filtre automatique, sur la base, mais je n'ai rien obtenu :

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
Sub Macro1()
'
' Macro1 Macro
'
 
'
    [A1:D50].AutoFilter
    ActiveSheet.Range("$A$1:$D$15").AutoFilter Field:=2, Criteria1:= _
                                               ">31/07/2012 23:59", Operator:=xlAnd
    ActiveSheet.Range("$A$1:$D$15").AutoFilter Field:=3, Criteria1:= _
                                               "<01/09/2012 00:00", Operator:=xlAnd
    Range("A2:A14").Select
    Selection.Copy
    Range("G2").Select
    ActiveSheet.Paste
    Range("E7").Select
End Sub

Merci d'avance.

**Daniel.C** · 09/09/2012, 14h48

Bonjour,

Je t'ai donné sur un autre forum la solution suivante :

Code :

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

1
2
3
4
5
6
7
8
Sub test()
Dim DerLigne As Long
[L2].FormulaArray = "=SUM((MONTH($B$2:$B$94)<=$H$2)*(MONTH($C$2:$C$94)>=$H$2)*($E$2:$E$94=Cause)" & _
"*($A$2:$A$94=K2)*((IF($C$2:$C$94<=DATE(2012,$H$2+1,0),$C$2:$C$94,DATE(2012,$H$2+1,0)))" & _
"-(IF($B$2:$B$94>DATE(2012,$H$2,1),$B$2:$B$94,DATE(2012,$H$2,1)))))"
DerLigne = Cells(Rows.Count, 11).End(xlUp).Row
[L2].AutoFill Range([M2], Cells(DerLigne, 12))
End Sub

à adapter, puisque le classeur est légèrement différent.
Tu t'embarques dans des galères avec les filtres, si tu filtres >31/07/20112 sur les dates de début, tu élimines toutes les lignes débutant avant août, même si la date de fin est postérieure au 1er août.

**apt** · 09/09/2012, 22h01

Bonsoir Daniel, le fil

Voila un petit essai (Code originel de mercatog, adapté), pour n'avoir que les sites concernés par les critères avancés, à savoir la période du mois d'août plus la cause "CS" :

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
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

Mais je n'ai rien en colonne K comme résultat !

Merci d'avance.

**Daniel.C** · 10/09/2012, 09h48

Tu la trouve où, la cause, sur ton classeur ? celui que tu as mis sur ce forum. Il faut être davantage précis. Tu fais perdre un temps considérable à ceux qui cherchent à résoudre tes problèmes.

**apt** · 10/09/2012, 15h29

Bonjour Daniel, le fil,

En PJ l'exemple.

Merci.

**Daniel.C** · 10/09/2012, 15h58

J'ai posté cette réponse sur mpfe ce matin. Pas de réponse jusqu'à maintenant :

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
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, 0) Then
                .Cells(C.Row, 15) = Application.Min(DateSerial(2012, Mois + 1, 0), 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, 0), "mm/dd/yyyy")
            If Application.Subtotal(103, .[A:A]) > 1 Then
                ligne = ligne + 1
                .Cells(ligne, 11) = Item
                .Cells(ligne, 12) = Application.Subtotal(109, .[C:C]) - Application.Subtotal(109, .[B:B])
            End If
        Next Item
        .AutoFilterMode = False
        .[N:O].ClearContents
    End With
End Sub

**apt** · 10/09/2012, 17h38

Bonsoir Daniel,

Je viens de le voir.

Je vais le tester.

**Daniel.C** · 10/09/2012, 18h10

Oups, quelques modifs :

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 As Integer
    Dim Item As Variant
    Ligne = 1
    Set Dico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1")
        Mois = Application.Match(.[H2], .[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, 0) Then
                .Cells(C.Row, 15) = Application.Min(DateSerial(2012, Mois + 1, 0), 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, .[I2]
            Plage1.AutoFilter 14, ">=" & Format(DateSerial(2012, Mois, 1), "mm/dd/yyyy")
            Plage1.AutoFilter 15, "<=" & Format(DateSerial(2012, Mois + 1, 0), "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])
            End If
        Next Item
        .AutoFilterMode = False
        .[N:O].ClearContents
    End With
End Sub

**mercatog** · 10/09/2012, 19h17

Bonjour
Pour calculer la durée en colonne F, pas besoin d'une fonction personnalisée. En F2

Code :

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

=ARRONDI(1440*(C2-B2);0)

Tu tires vers la bas (1440=60*24: nombre de minutes dans une journée)

Ensuite, pour le code(initial, tu le mal adapté nécessairement dû à une mal compréhension ou interprétation).
Le code tel, recense les sites répondant aux critères et inscrit la somme des temps d'arrêt pour chaque site.

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
Sub CalculeDureeTotalSite()
Const Cible As String = "K2"
Dim Str As String, Cause As String, LaCause 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 Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range(Cible).Resize(LastLig, 2).ClearContents
    Tb = .Range("A2:F" & LastLig)
    LaCause = .[Cause]
    MoisNum = Application.Match(.[Mois], .
[ListeMois], 0)
    .[H3].Value = MoisNum
    For i = 1 To UBound(Tb, 1)
        M1 = Format(Tb(i, 2), "mm")
        M2 = Format(Tb(i, 3), "mm")
        Cause = Tb(i, 5)
 
        If (M1 = MoisNum Or M2 = MoisNum) And Cause = LaCause Then
            Str = Tb(i, 1)
            If Not MonDico.Exists(Str) Then
                MonDico.Add Str, Tb(i, 6)
            Else
                MonDico(Str) = MonDico(Str) + Tb(i, 6)
            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).Resize(n, 2).Sort Key1:=.Range(Cible), Order1:=xlAscending, Header:=xlNo
    End If
End With
End Sub

**apt** · 11/09/2012, 01h33

Bonjour Daniel, mercatog,

Daniel :: Le traitement ce fait normalement pour les dates qui s'étalent entre Juillet-Août et Août-Août, mais ne marche pas pour celles qui s'étalent entre Août-Septembre.

Par exemple, les cas suivants, ne sont pas traiter par le code :

MSF 29/08/2012 22:21 02/09/2012 09:48 03 jour 11h:27mn CS
TID 31/08/2012 17:20 02/09/2012 08:54 01 jour 15h:34mn CS
SDA 31/08/2012 17:05 03/09/2012 17:26 03 jour 00h:21mn CS
SHA 30/08/2012 17:06 01/09/2012 17:26 02 jour 00h:20mn CS

mercatog :: ça avance, mais le compte des durées totales, n'est pas bon

Par exemple pour le cas ADB :

ADB 30/07/2012 13:57 01/08/2012 15:41 02 jour 01h:44mn CS
ADB 09/08/2012 00:31 09/08/2012 11:59 00 jour 11h:28mn CS

On doit faire le calcul sur :

ADB 01/08/2012 00:00 01/08/2012 15:41 00 jour 15h:41mn CS
ADB 09/08/2012 00:31 09/08/2012 11:59 00 jour 11h:28mn CS

Pour trouver :

1 jour(s) 03 heure(s) 09 minute(s)

Or le code trouve :

19 jour(s) 00 heure(s) 00 minute(s)

Enfin le code doit traiter les cas des dates qui s'étalent entre deux mois, et ne doit calculer que les durées entre le 1er et le dernier jour de mois choisi dans la liste de validation des mois.

Merci.

**mercatog** · 11/09/2012, 10h34

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
Option Explicit
 
Sub CalculeDureeTotalSite()
Const Cible As String = "K2"
Dim LastLig As Long, i As Long, n As Long, Duree As Long
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 = Round(1440 * (Tb(i, 3) - Tb(i, 2)), 0)
                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).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

**Daniel.C** · 11/09/2012, 10h42

Bonjour,

MSF 29/08/2012 22:21 02/09/2012 09:48 03 jour 11h:27mn CS

Nan, 7 mn pour CS, pour l'autre ligne, la cause est : RSBF (CS). Si ça doit être comptabilisé comme CS, il faudra - et il aurait fallu le faire dès le début - que tu expliques comment on comptabilise (pourquoi "CS" et pas "RSBF" par exemple.

TID 31/08/2012 17:20 02/09/2012 08:54 01 jour 15h:34mn CS

Je n'ai pas 31/08/2012 mais 01/09/2012.
Je n'ai pas été voir plus loin. Ça fait deux fois que tu me signales, à tort, des erreurs. Tu dois avoir plus de rigueur dans tes énoncés et dans tes réponses. Tu vas finir par lasser du monde.

**apt** · 11/09/2012, 14h53

Bonsoir mercatog,

Merci pour le nouveau code.

J'ai trouvé une fonction pour formater la durée en colonne L qui donnée en minutes, mais je n'ai pas ressui à l'appliquer sur les résultats dans le tableau RES :

Code :

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

1
2
ActiveCell.Formula = _
        "=TEXT(" & [L2] & "/1440,""jj"""" jours"""" hh"""" heures"""" mm"""" minutes"""""")"

Merci.

**mercatog** · 11/09/2012, 15h11

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
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

**apt** · 11/09/2012, 18h15

Bonsoir Daniel,

Envoyé par Daniel.C

Bonjour,
Nan, 7 mn pour CS, pour l'autre ligne, la cause est : RSBF (CS). Si ça doit être comptabilisé comme CS

Non, chaque cause d'arrêt doit être comptabilisée à part.

pourquoi "CS" et pas "RSBF" par exemple)

Comme pour CS, le traitement sera appliqué pour RBSF ou TRM ou DJC...

Je n'ai pas 31/08/2012 mais 01/09/2012.
Je n'ai pas été voir plus loin. Ça fait deux fois que tu me signales, à tort, des erreurs. Tu dois avoir plus de rigueur dans tes énoncés et dans tes réponses. Tu vas finir par lasser du monde.

C'est en faisant des testes sur des cas réels que je m’aperçois que je devrais prendre en compte ces nouveaux cas.

Et excuses, pour la peine que vous prenez pour répondre à mes questions

Merci d’avance.

EDIT :

Bonsoir mercatog,

Le formatage directe, donne un faut résultat.

C'est pour cela que j'aimerais appliqué un calcul avec un formatage de résultat par la formule :

Code :

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

ActiveCell.Formula = "=TEXT(" & [L2] & "/1440,""jj"""" jours"""" hh"""" heures"""" mm"""" minutes"""""")"

Merci.

**mercatog** · 11/09/2012, 19h10

Le formatage directe, donne un faux résultat

Faux. Il donne le bon résultat.
Penses un tout petit peu et dis nous comment le format d'une cellule peut altérer le contenu réel de la même cellule.

**Daniel.C** · 11/09/2012, 19h45

Au temps pour moi pour les jours limite :

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
Sub test()
    Dim Dico As Object, C As Range, Mois As Integer, Plage As Range, Plage1 As Range, Ligne As Integer
    Dim Item As Variant
    Application.ScreenUpdating = False
    Ligne = 1
    Set Dico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1")
        Mois = Application.Match(.[H2], .[Q:Q], 0)
        For Each C In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
            If (C.Offset(, 1) < DateSerial(2012, Mois, 1) And C.Offset(, 2) < DateSerial(2012, Mois, 1)) Or _
            (C.Offset(, 1) > DateSerial(2012, Mois + 1, 1) And C.Offset(, 2) > DateSerial(2012, Mois + 1, 1)) Then
                .Cells(C.Row, 14) = 0
                .Cells(C.Row, 15) = 0
            Else
                .Cells(C.Row, 14) = Application.Max(DateSerial(2012, Mois, 1), C.Offset(, 1))
                .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, .[I2]
            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])
            End If
        Next Item
        .AutoFilterMode = False
        .[N:O].ClearContents
    End With
    Application.ScreenUpdating = False
End Sub

**apt** · 11/09/2012, 23h09

Bonsoir mercatog, Daniel,

Envoyé par mercatog

dis nous comment le format d'une cellule peut altérer le contenu réel de la même cellule.

En colonne L, pour le cas ADB, on a une durée totale de 1629 minutes.

Si on applique le format suivant :

jj "jour(s)" hh" heure(s) "mm" minute(s)"

Sur la cellule en L2, on aura :

ADB 16 jour(s) 00 heure(s) 00 minute(s)

Au lieu de :

ADB 01 jour(s) 03 heure(s) 09 minute(s)

Pour régler le problème du format j'ai ajouté dans le code de mercatog ces lignes :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Columns("K:M").ClearContents
            .Range(Cible).Resize(n, 2) = Res
            Columns("L:L").Insert Shift:=xlToRight
            .Range(Cible).Offset(-1, 0) = "Site"
            .Range(Cible).Offset(-1, 1) = "Durée total de l'arrêt"
            .Range(Cible).Offset(-1, 2) = "Durée (Min)"
            .Range(Cible).Offset(0, 1).Formula = _
            "=TEXT(M2/1440,""jj"""" jours"""" hh"""" heures"""" mm"""" minutes"""""")"
 
            .Range(Cible).Offset(0, 1).AutoFill Range("L2:L" & n + 1)
            .Range(Cible).Offset(0, 1).EntireColumn.AutoFit
 
            .Range(Cible).Resize(n, 3).Sort Key1:=.Range(Cible), Order1:=xlAscending, Header:=xlNo

Un code similaire a été ajouter dans le code de Daniel, mais il manque quelques rectifications :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
'---------------
        .Columns("L:L").Insert Shift:=xlToRight
        .Cells(1, "K") = "Site"
        .Cells(1, "L") = "Durée total de l'arrêt"
        .Cells(1, "M") = "Durée (Min)"
        .Cells(2, "L").Formula = _
        "=TEXT(M2/1440,""jj"""" jours"""" hh"""" heures"""" mm"""" minutes"""""")"
 
        Ligne = .Cells(.Rows.Count, "K").End(xlUp).Row
        .Cells(2, "L").AutoFill Range("L2:L" & Ligne)
        .Cells(2, "L").EntireColumn.AutoFit
        .Cells(2, "K").Resize(Ligne, 3).Sort Key1:=.Cells(2, "K"), Order1:=xlAscending, Header:=xlNo
        '---------------

J'ai joins un classeur exemple contenant les deux codes dans deux l'onglet : "Daniel" et "mercatog".

Merci.

**Daniel.C** · 12/09/2012, 10h03

Bonjour,

Un code similaire a été ajouter dans le code de Daniel, mais il manque quelques rectifications :

Sans doute, mais lesquelles ?

**apt** · 12/09/2012, 15h42

Bonsoir Daniel,

Envoyé par Daniel.C

Sans doute, mais lesquelles ?

Les lignes de codes ajoutées entre :

Code :

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

1
2
3
4
 
'------------
 
'------------

Et voila le code de la macro test :

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
Sub test()
    Dim Dico As Object, C As Range, Mois As Integer, Plage As Range, Plage1 As Range, Ligne As Integer
    Dim Item As Variant, Ligne1 As Integer
    Application.ScreenUpdating = False
    Ligne = 1
    Set Dico = CreateObject("Scripting.Dictionary")
    With Feuil1
        '--------
        Columns("K:M").Clear
        '---------
        Mois = Application.Match(.[G2], Feuil3.[A:A], 0)
        For Each C In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
            If (C.Offset(, 1) < DateSerial(2012, Mois, 1) And C.Offset(, 2) < DateSerial(2012, Mois, 1)) Or _
               (C.Offset(, 1) > DateSerial(2012, Mois + 1, 1) And C.Offset(, 2) > DateSerial(2012, Mois + 1, 1)) Then
                .Cells(C.Row, 14) = 0
                .Cells(C.Row, 15) = 0
            Else
                .Cells(C.Row, 14) = Application.Max(DateSerial(2012, Mois, 1), C.Offset(, 1))
                .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, .[I2]
            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])
            End If
        Next Item
 
        '---------------
        .Columns("L:L").Insert Shift:=xlToRight
        .Cells(1, "K") = "Site"
        .Cells(1, "L") = "Durée total de l'arrêt"
        .Cells(1, "M") = "Durée (Min)"
        .Cells(2, "L").Formula = _
         "=TEXT(M2/1440,""jj"""" jours"""" hh"""" heures"""" mm"""" minutes"""""")"
 
        Ligne = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Cells(2, "L").AutoFill Range("L2:L" & Ligne)
        .Cells(2, "L").EntireColumn.AutoFit
        .Cells(2, "K").Resize(Ligne, 3).Sort Key1:=.Cells(2, "K"), Order1:=xlAscending, Header:=xlNo
        '---------------
        .AutoFilterMode = False
        .[O:P].ClearContents
    End With
    Application.ScreenUpdating = False
End Sub

Extraction de données avec calcul [XL-2007]

Macros et VBA Excel

Discussions similaires

Partager

Partager