Optimisation de Code VBA

Le 02/11/2013 à 14:25

Bonjour la communauté

qui pourrait m'aider à optimiser cette VBA qui tourne trop lentement ( j'ai 50000 lignes à traiter)

Merci d'avance de vos conseils

Sub commande()

Sheets("SXX 2013").Columns("L").Copy
Sheets("TEST6").Range("A1").Select
ActiveSheet.Paste

ActiveSheet.Columns("A").RemoveDuplicates Columns:=1, Header:= _
        xlYes

 For i = 2 To Sheets("TEST6").Range("A100000").End(xlUp).Row

     With Sheets("SXX 2013")
       Sheets("TEST6").Range("B" & i) = Application.WorksheetFunction.SumIf(.Columns("L"), Sheets("TEST6").Cells(i, 1), .Columns("J"))
       Sheets("TEST6").Range("C" & i) = Application.WorksheetFunction.SumIf(.Columns("L"), Sheets("TEST6").Cells(i, 1), .Columns("J")) - Application.WorksheetFunction.SumIf(.Columns("L"), Sheets("TEST6").Cells(i, 1), .Columns("K")) - Application.WorksheetFunction.SumIf(.Columns("L"), Sheets("TEST6").Cells(i, 1), .Columns("Q"))
       Sheets("TEST6").Range("D" & i) = Sheets("TEST6").Range("C" & i) / Sheets("TEST6").Range("B" & i)
       Sheets("TEST6").Range("E" & i) = Application.WorksheetFunction.SumIf(.Columns("L"), Sheets("TEST6").Cells(i, 1), .Columns("I"))
       Sheets("TEST6").Range("F" & i) = Sheets("TEST6").Range("B" & i) / Sheets("TEST6").Range("E" & i)

     End With

 Next i

End Sub
Le 02/11/2013 à 14:54

Bonjour

Sans fichier

Essayes (sans conviction)

Sub commande()

  With Sheets("TEST6")
    Sheets("SXX 2013").Columns("L").Copy S.Range("A1")

    .Columns("A").RemoveDuplicates Columns:=1, Header:=xlYes

    .Range("B2").Formula = "=SUMIF('SXX 2013'!$L:$L,A2,'SXX 2013'!$J:$J)"
    .Range("C2").Formula = "=SUMIF('SXX 2013'!$L:$L,A2,'SXX 2013'!$J:$J)-SUMIF('SXX 2013'!$L:$L,A2,'SXX 2013'!$K:$K)-SUMIF('SXX 2013'!$L:$L,A2,'SXX 2013'!$Q:$Q)"
    .Range("D2").Formula = "=C2/B2"
    .Range("E2").Formula = "=SUMIF('SXX 2013'!$L:$L,A2,'SXX 2013'!$I:$I)"
    .Range("F2").Formula = "=B2/E2"
    .Range("B2:F2").AutoFill .Range("B2:F" & .Range("A" & Rows.Count).End(xlUp).Row), xlFillSeries
    With .Range("B2:F" & .Range("A" & Rows.Count).End(xlUp).Row)
      .Value = .Value
    End With
  End With
End Sub
Le 02/11/2013 à 15:25

merci banzai pour ton code mais il y a plus de 67000 lignes à calculer avec des fonctions...

du coup il a pas le temps de calculer que la macro vient coller en valeur brute.

mon fichier est trop lourd pour te l'envoyer

donc voici un extrait sachant que dans "SXX 2013" il y a 100000 lignes et dans "TEST 6" 50000 lignes

24classeur2.xlsm (18.77 Ko)
Le 02/11/2013 à 16:26

Bonjour

En limitant dans la formule le nombre de ligne (à la place de prendre toute la colonne)

Je trouve bizarre autant qu'étrange (mais je ne connais pas tout) qu' XL commence un autre boulot sans avoir finit le premier

Essayes

Sub commande()
Dim NbLg As Long

  NbLg = Sheets("SXX 2013").Range("L" & Rows.Count).End(xlUp).Row
  With Sheets("TEST6")
    Sheets("SXX 2013").Columns("L").Copy .Range("A1")

    .Columns("A").RemoveDuplicates Columns:=1, Header:=xlYes
    .Range("B2").Formula = "=SUMIF('SXX 2013'!$L$2:$L$" & NbLg & ",A2,'SXX 2013'!$J$2:$J$" & NbLg & ")"
    .Range("C2").Formula = "=SUMIF('SXX 2013'!$L$2:$L$" & NbLg & ",A2,'SXX 2013'!$J$2:$J$" & NbLg & ")-SUMIF('SXX 2013'!$L$2:$L$" & NbLg & ",A2,'SXX 2013'!$K$2:$K$" & NbLg & ")-SUMIF('SXX 2013'!$L$2:$L$" & NbLg & ",A2,'SXX 2013'!$Q$2:$Q$" & NbLg & ")"
    .Range("D2").Formula = "=C2/B2"
    .Range("E2").Formula = "=SUMIF('SXX 2013'!$L$2:$L$" & NbLg & ",A2,'SXX 2013'!$I$2:$I$" & NbLg & ")"
    .Range("F2").Formula = "=B2/E2"
    .Range("B2:F2").AutoFill .Range("B2:F" & .Range("A" & Rows.Count).End(xlUp).Row), xlFillSeries

    With .Range("B2:F" & .Range("A" & Rows.Count).End(xlUp).Row)
      .Value = .Value
    End With
  End With
End Sub
Le 02/11/2013 à 20:20

Bonsoir,

Bonsoir Banzaï

Je suis parti sur une autre piste, c'est à dire faire tous les calculs en mémoire....

Sur le fichier exemple, en mettant 22 000 lignes, dont 11 000 différentes en colonne L, la solution avec formule met en gros une vingtaine de secondes...

Avec le code ci-dessous, un peu plus d'une seconde (nota, j'avais mis les mêmes conditions, "ScreenUpdating" à "False", et "Calculation" en "Manual"

Je te laisse découvrir, et essayer

Bon courage

Sub hub()
Dim Total1 As Object, Total2 As Object, Total3 As Object
Dim Quotient1 As Object, Quotient2 As Object
Dim Cel As Range
Dim It, T
Dim DerLig As Long
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
T = Timer
Set Total1 = CreateObject("Scripting.Dictionary")
Set Total2 = CreateObject("Scripting.Dictionary")
Set Total3 = CreateObject("Scripting.Dictionary")
Set Quotient2 = CreateObject("Scripting.Dictionary")
Set Quotient1 = CreateObject("Scripting.Dictionary")
With Sheets("SXX 2013")
    DerLig = .Cells(Rows.Count, "L").End(xlUp).Row
    For Each Cel In .Range("L2:L" & DerLig)
        Total1(Cel.Value) = Total1(Cel.Value) + Cel.Offset(, -2).Value
        Total2(Cel.Value) = Total2(Cel.Value) + Cel.Offset(, -2).Value - Cel.Offset(, -1).Value - Cel.Offset(, 5).Value
        Total3(Cel.Value) = Total3(Cel.Value) + Cel.Offset(, -3).Value
    Next Cel
End With
For Each It In Total1.Keys
    Quotient1(It) = Total2(It) / Total1(It)
    Quotient2(It) = Total1(It) / Total3(It)
Next It
With Sheets("TEST6")
    .Range("A2").Resize(Total1.Count) = Application.Transpose(Total1.Keys)
    .Range("B2").Resize(Total1.Count) = Application.Transpose(Total1.Items)
    .Range("C2").Resize(Total1.Count) = Application.Transpose(Total2.Items)
    .Range("D2").Resize(Total1.Count) = Application.Transpose(Quotient1.Items)
    .Range("E2").Resize(Total1.Count) = Application.Transpose(Total3.Items)
    .Range("F2").Resize(Total1.Count) = Application.Transpose(Quotient2.Items)
    .Columns("D:D").NumberFormat = "0%"
    .Range("B:C,E:F").NumberFormat = "0.00"
End With
Application.Calculation = xlCalculationAutomatic
MsgBox Timer - T
End Sub

Bonne soirée à tous

Le 02/11/2013 à 22:52

Merci Banzai94 et merci cousin Hub

j'aimerais bien comprendre cette macro si tu as le temps de m'expliquer

@ cousin hub : le code bloque à ce passage car "incompatibilité de type".

J'ai fait un test avec + de 300000 lignes sur la feuille "SXX 2013" et ca fonctionne sans soucis...avec comme résultat 63000 lignes en feuille "TEST6"

En revanche des que je depasse 65000 lignes sur la feuille "TEST6" et cela, malgré que sur feuille "SXX 2013" il y a moins de 100000 lignes

With Sheets("TEST6")
    .Range("A2").Resize(Total1.Count) = Application.Transpose(Total1.Keys)
    .Range("B2").Resize(Total1.Count) = Application.Transpose(Total1.Items)
    .Range("C2").Resize(Total1.Count) = Application.Transpose(Total2.Items)
    .Range("D2").Resize(Total1.Count) = Application.Transpose(Quotient1.Items)
    .Range("E2").Resize(Total1.Count) = Application.Transpose(Total3.Items)
    .Range("F2").Resize(Total1.Count) = Application.Transpose(Quotient2.Items)
Le 02/11/2013 à 23:29

Re-,

Quelle ligne est surlignée en "jaune"?

Car tu m'indiques une "partie", et non une ligne...

Pour info, j'utilise un objet "Scripting.Dictionary", objet très rapide, et bien plus rapide qu'un tableau VBA.

Quelques sites en parlent, notamment "boisgontierjacques" (recherche sur G......)

Bon courage

Le 02/11/2013 à 23:33

Re,

De nouveau, l'utilisation d'un TCD permettrait un gain de traitement

Cdlt

Le 02/11/2013 à 23:38

Cousin Hub,

en terme de rapidité, c'est plus que parfait 12sec pour traiter 300 000 lignes

le code met en jaune : .Range("A2").Resize(Total1.Count) = Application.Transpose(Total1.Keys)

J'ai fait un test avec + de 300000 lignes sur la feuille "SXX 2013" et ca fonctionne sans soucis...avec comme résultat 63000 lignes en feuille "TEST6"

En revanche des que je depasse 65000 lignes sur la feuille "TEST6" et cela, malgré que sur feuille "SXX 2013" il y a moins de 100000 lignes

Le 02/11/2013 à 23:55

Re,

Voir fichier avec TCD et 2 champs calculés.

(automatisation par VBA évidemment possible, comme pour le prédent post)

Cdlt

26tcd-hyppo8010-v2.xlsm (23.21 Ko)
Rechercher des sujets similaires à "optimisation code vba"