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

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

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager