Extraction conditionnelle un peu compliquée

Y compris Power BI, Power Query et toute autre question en lien avec Excel
d
dubois
Passionné d'Excel
Passionné d'Excel
Messages : 9'273
Inscrit le : 8 décembre 2007
Version d'Excel : Vista Office 2007FR

Message par dubois » 17 juin 2009, 22:03

Bonsoir à tous,

Anthony, 2 nouvelles macros testées sur 200284 lignes, le temps de traitement ne
dépasse pas 34 secondes dans le pire des cas (2)
Sub ExtraitAvecFormules()
''Claude le 17 juin 09
Dim Lg As Long, Nb&, Nb1&, Nb2&, i As Byte
Dim Cel As Range
Dim Plg As Variant, X As Variant, y As Variant, Cycle As Variant
X = Time
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
On Error Resume Next
        ActiveSheet.ShowAllData 'libère le filtre
On Error GoTo 0
    Lg = Range("A2").End(xlDown).Row
    Range("s13:s" & Lg).ClearContents
    Range("a2:q" & Lg).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("u1:u2"), Unique:=False
'On Error GoTo FIN
    Cycle = Lg / 10000 'cycle boucle
    Nb = Lg / Cycle
    Set Plg = Range(Range("s" & 3), Range("s" & Nb)).SpecialCells(xlCellTypeVisible)
    Plg.FormulaR1C1 = "=IF(SUMPRODUCT((R[1]C[-17]:R[10]C[-17]=RC[-17])*(R[1]C[-11]:R[10]C[-11]+R[1]C[-7]:R[10]C[-7]=RC[-11]+RC[-7]+TIME(R1C13,0,0))+(SUMPRODUCT((R[-10]C[-17]:R[-1]C[-17]=RC[-17])*(R[-10]C[-11]:R[-1]C[-11]+R[-10]C[-7]:R[-1]C[-7]=RC[-11]+RC[-7]-TIME(R1C13,0,0)))))>0, 1, 0)"
    For i = 2 To Cycle
            Nb1 = WorksheetFunction.Max(Nb, Nb2)
            Nb2 = Nb1 + Nb
        Set Plg = Range(Range("s" & Nb1), Range("s" & Nb2)).SpecialCells(xlCellTypeVisible)
        Plg.FormulaR1C1 = "=IF(SUMPRODUCT((R[1]C[-17]:R[10]C[-17]=RC[-17])*(R[1]C[-11]:R[10]C[-11]+R[1]C[-7]:R[10]C[-7]=RC[-11]+RC[-7]+TIME(R1C13,0,0))+(SUMPRODUCT((R[-10]C[-17]:R[-1]C[-17]=RC[-17])*(R[-10]C[-11]:R[-1]C[-11]+R[-10]C[-7]:R[-1]C[-7]=RC[-11]+RC[-7]-TIME(R1C13,0,0)))))>0, 1, 0)"
            For Each Cel In [Plg]
                Cel = Cel.Value 'écrit en dur
            Next Cel
    Next i
        '************** 2ème filtre ne sort que les 1 *********
    Range("a2:s" & Lg).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("v1:v2"), Unique:=False
    Range("s:s").Clear
    Application.Goto Range("a3"), Scroll:=True
    Range("m1").Activate
            With Application
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            End With
    y = Time
    MsgBox ("temps macro = " & Format(y - X, "hh:mm:ss"))
    Exit Sub
FIN: MsgBox ("erreur !ou pas de données")
    Application.EnableEvents = True
End Sub
Et macro de Dan qui à bien voulu nous aider
Sub ExtraitAvecFormulesDan()
Dim Lg As Long, i As Long
Dim X As Variant, y As Variant
X = Time
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
 
On Error Resume Next
    ActiveSheet.ShowAllData 'libère le filtre
On Error GoTo 0
    Lg = Range("A2").End(xlDown).Row
    Range("s13:s" & Lg).ClearContents
    Range("a2:q" & Lg).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("u1:u2"), Unique:=False
 
On Error GoTo FIN
    For i = 3 To Lg
        If ActiveSheet.Rows(i).Hidden = False Then
            With Range("S" & i)
                .FormulaR1C1 = "=IF(SUMPRODUCT((R[1]C[-17]:R[10]C[-17]=RC[-17])*(R[1]C[-11]:R[10]C[-11]+R[1]C[-7]:R[10]C[-7]=RC[-11]+RC[-7]+TIME(R1C13,0,0))+(SUMPRODUCT((R[-10]C[-17]:R[-1]C[-17]=RC[-17])*(R[-10]C[-11]:R[-1]C[-11]+R[-10]C[-7]:R[-1]C[-7]=RC[-11]+RC[-7]-TIME(R1C13,0,0)))))>0, 1, 0)"
                Range("S" & i) = Range("S" & i)
            End With
        End If
    Next
        '************** 2ème filtre ne sort que les 1 *********
    Range("a2:s" & Lg).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("v1:v2"), Unique:=False
    Range("s:s").Clear
    Application.Goto Range("a3"), Scroll:=True
    Range("m1").Activate
        With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        End With
    y = Time
    MsgBox ("temps macro = " & Format(y - X, "hh:mm:ss"))
    Exit Sub
FIN: MsgBox ("erreur !ou pas de données")
    Application.EnableEvents = True
End Sub
tu choisiras, mais n'oublie pas de changer le Private Sub
pour l'une ou l'autre,
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Not Application.Intersect(Target, Range("m1")) Is Nothing Then
        Call ExtraitAvecFormules
        'Call ExtraitAvecFormulesDan
        End If
End Sub
Tiens-nous au courant
Amicalement
Claude.
Faire simple, c'est ce qui est le plus compliqué ! et vice versa (à méditer)
d
dubois
Passionné d'Excel
Passionné d'Excel
Messages : 9'273
Inscrit le : 8 décembre 2007
Version d'Excel : Vista Office 2007FR

Message par dubois » 18 juin 2009, 12:27

Bonjour à tous,

Macro modifiée, 22 secondes maxi
Sub ExtraitAvecFormules()
''Claude le 18 juin 09
Dim Lg As Long, Nb&, Nb1&, Nb2&, i As Byte
Dim Cel As Range
Dim Plg As Variant, X As Variant, Y As Variant, Cycle As Variant
X = Time
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
On Error Resume Next
        ActiveSheet.ShowAllData 'libère le filtre
On Error GoTo 0
    Lg = Range("A2").End(xlDown).Row
    Range("s13:s" & Lg).ClearContents
    Range("a2:q" & Lg).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("u1:u2"), Unique:=False
'On Error GoTo FIN
    'Cycle = Lg / 10000 'cycle boucle
     Cycle = WorksheetFunction.Ceiling(Lg / 10000, 1)
    Nb = Lg / Cycle
    For i = 1 To Cycle
            Nb1 = WorksheetFunction.Max(3, Nb2)
            Nb2 = Nb1 + Nb
        Set Plg = Range(Range("s" & Nb1), Range("s" & Nb2)).SpecialCells(xlCellTypeVisible)
        Plg.FormulaR1C1 = "=IF(SUMPRODUCT((R[1]C[-17]:R[10]C[-17]=RC[-17])*(R[1]C[-11]:R[10]C[-11]+R[1]C[-7]:R[10]C[-7]=RC[-11]+RC[-7]+TIME(R1C13,0,0))+(SUMPRODUCT((R[-10]C[-17]:R[-1]C[-17]=RC[-17])*(R[-10]C[-11]:R[-1]C[-11]+R[-10]C[-7]:R[-1]C[-7]=RC[-11]+RC[-7]-TIME(R1C13,0,0)))))>0, 1, 0)"
            For Each Cel In [Plg]
                Cel = Cel.Value 'écrit en dur
            Next Cel
    Next i
        '************** 2ème filtre ne sort que les 1 *********
    Range("a2:s" & Lg).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("v1:v2"), Unique:=False
    Range("s:s").Clear
    Application.Goto Range("a3"), Scroll:=True
    Range("m1").Activate
            With Application
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            End With
    Y = Time
    MsgBox ("temps macro = " & Format(Y - X, "hh:mm:ss"))
    Exit Sub
FIN: MsgBox ("erreur !ou pas de données")
    Application.EnableEvents = True
End Sub
à titre indicatif, et sans esprit de compétition :
Image
Mais Dan n'a peut-être pas dit son dernier mot !
Amicalement
Claude.
Faire simple, c'est ce qui est le plus compliqué ! et vice versa (à méditer)
A
Anthax
Jeune membre
Jeune membre
Messages : 45
Inscrit le : 1 juin 2009
Version d'Excel : 2007 EN

Message par Anthax » 18 juin 2009, 18:51

:sp:

Lol !
Vous êtes des bons !
Je suis sur le terrain, donc je ne peux pas trop m'occuper d'essayer la macro pour l'instant - mais j'essaye de voir ça ce week-end !
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message