Optimisation de code - condition if ... and

Bonjour,

J'aimerai améliorer la rapidité d'exécution de mon code.

Pour mettre un peu de contexte je veux réaliser une journée type "moyenne" de 24h à partir de courbes de charge électriques sur une année. Les critères sont les jours de la semaine (lundi ? mardi ? ...) et la saison (hiver, été)
Je veux 2 journées types différentes.

Je fais donc une sorte de moyenne, sur de très nombreuses conditions. et la structure classique de MOYENNE.SI.ENS d'excel de me permet pas d'y arriver. J'ai donc décider d'essayer par une macro.

L'idée générale est de repérer les cellules correspondants à mes critères, puis de les sommer et de diviser cette somme par le nombre de cellules. Je fais donc une moyenne arithmétique "a la mano".

Je fais 2 boucles "for" imbriquées (une sur 52000 cellules et l'autre sur 144 cellules) au total j'ai donc un grand nombre d'opérations à faire, et le moindre dixième de seconde gagné est très important.

A l'intérieur de mes boucles for, j'ai de nombreuses conditions "IF", et j'utilise les structures IF... AND

Pouvez-vous me dire s'il y a un moyen d'optimiser cette méthode ? Ou si le code en lui-même peut être optimisé (par exemple j'ai lu qu'en déclarant les variables utilisées dans mes boucles "for", on gagne un peu de temps)

Merci d'avance !!

Ci-dessous le code en question

Sub JourneeMoyenne2()

Dim Tablo(143, 1)
Dim P10()
Dim deb, fin, A, Somme, Saison_1, Saison_2
Dim Heures(), Jour_1(), Jour_2(), Hiver(), Ete()

With Worksheets("Calcul")

Saison_1 = .Range("I4")
Saison_2 = .Range("J4")

Jour_1 = .Range("I5:I11").Value
Jour_2 = .Range("J5:J11").Value

ReDim Heures(143)
Heures = .Range("H13:H156").Value

End With

Hiver = Array(1, 2, 11, 12)
Ete = Array(6, 7, 8, 9)

With Worksheets("10min")

deb = .Range("pts_10_min").Row
fin = .Range("pts_10_min").Cells(1, 1).End(xlDown).Row

ReDim P10(fin - deb, 3)
Dim j As Long

For j = 0 To UBound(P10)
P10(j, 0) = .Range("C" & j + deb) 'heure
P10(j, 1) = .Range("D" & j + deb) 'puissance
P10(j, 2) = .Range("F" & j + deb) 'jour
P10(j, 3) = .Range("G" & j + deb) 'mois
Next j

Dim i As Integer
Dim s As Long

'Journée moyenne 1
A = 0
Somme = 0

Dim temps As Double

For i = 0 To UBound(Tablo) - 1
temps = Timer
For s = deb To fin
j = s - deb
If P10(j, 0) = Heures(i + 1, 1) And Not IsError(Application.Match(P10(j, 2), Jour_1, 0)) Then

If Saison_1 = "Année complète" Or _
(Saison_1 = "Hiver" And Not IsError(Application.Match(P10(j, 3), Hiver, 0))) Or _
(Saison_1 = "Eté" And Not IsError(Application.Match(P10(j, 3), Ete, 0))) Then

Somme = Somme + P10(j, 1)
A = A + 1

End If
End If
Next s

If Somme = 0 Or A = 0 Then
Tablo(i, 0) = 0
Else
Tablo(i, 0) = Somme / A
End If
Debug.Print Timer - temps
Next i

'Journée moyenne 2
A = 0
Somme = 0

For i = 0 To UBound(Tablo) - 1
For s = deb To fin
If .Range("C" & s) = Heures(i + 1, 1) And Not IsError(Application.Match(.Range("F" & s), Jour_2, 0)) Then

If Saison_2 = "Année complète" Or _
(Saison_2 = "Hiver" And Not IsError(Application.Match(.Range("G" & s), Hiver, 0))) Or _
(Saison_2 = "Eté" And Not IsError(Application.Match(.Range("G" & s), Ete, 0))) Then

Somme = Somme + .Range("D" & s)
A = A + 1

End If
End If
Next s

If Somme = 0 Or A = 0 Then
Tablo(i, 1) = 0
Else
Tablo(i, 1) = Somme / A
End If

Next i

End With

'Colle le tableau dans excel
Worksheets("Calcul").Range("I13:J156") = Tablo

End Sub

3 réponses

  • Votes
  • Date
  • Date décroissante
  1. Bonjour,

    Vous pouvez faire journee1 et 2 dans la meme boucle, si je ne m'abuse

    Sub JourneeMoyenne2()
    
    Dim Tablo(143, 1)
    Dim P10()
    Dim deb, fin, A, Somme, Saison_1, Saison_2
    Dim Heures(), Jour_1(), Jour_2(), Hiver(), Ete()
    
    Application.ScreenUpdating = False
    With Worksheets("Calcul")
        Saison_1 = .Range("I4")
        Saison_2 = .Range("J4")
        Jour_1 = .Range("I5:I11").Value
        Jour_2 = .Range("J5:J11").Value
        ReDim Heures(143)
        Heures = .Range("H13:H156").Value
    End With
    
    Hiver = Array(1, 2, 11, 12)
    Ete = Array(6, 7, 8, 9)
    
    
    With Worksheets("10min")
        Dim j As Long
        deb = .Range("pts_10_min").Row
        fin = .Range("pts_10_min").Cells(1, 1).End(xlDown).Row
    
        ReDim P10(fin - deb, 3)
    
        For j = 0 To UBound(P10)
            P10(j, 0) = .Range("C" & j + deb) 'heure
            P10(j, 1) = .Range("D" & j + deb) 'puissance
            P10(j, 2) = .Range("F" & j + deb) 'jour
            P10(j, 3) = .Range("G" & j + deb) 'mois
        Next j
    
        Dim i As Integer
        Dim s As Long
    
        A = 0:    Somme = 0
        A1 = 0:    Somme1 = 0
    
        Dim temps As Double
    
        FT = UBound(Tablo) - 1
        For i = 0 To FT
            temps = Timer
            For s = deb To fin
                'Journée moyenne 1
                j = s - deb
                If P10(j, 0) = Heures(i + 1, 1) And Not IsError(Application.Match(P10(j, 2), Jour_1, 0)) Then
                    If Saison_1 = "Année complète" Or _
                        (Saison_1 = "Hiver" And Not IsError(Application.Match(P10(j, 3), Hiver, 0))) Or _
                        (Saison_1 = "Eté" And Not IsError(Application.Match(P10(j, 3), Ete, 0))) Then
                        Somme = Somme + P10(j, 1): A = A + 1
                    End If
                End If
                'Journée moyenne 2
                If .Range("C" & s) = Heures(i + 1, 1) And Not IsError(Application.Match(.Range("F" & s), Jour_2, 0)) Then
                    If Saison_2 = "Année complète" Or _
                        (Saison_2 = "Hiver" And Not IsError(Application.Match(.Range("G" & s), Hiver, 0))) Or _
                    (Saison_2 = "Eté" And Not IsError(Application.Match(.Range("G" & s), Ete, 0))) Then
                        Somme = Somme + .Range("D" & s): A = A + 1
                    End If
                End If
            Next s
            If Somme = 0 Or A = 0 Then Tablo(i, 0) = 0 Else Tablo(i, 0) = Somme / A
            If Somme1 = 0 Or A1 = 0 Then Tablo(i, 1) = 0 Else Tablo(i, 1) = Somme1 / A1
            Debug.Print Timer - temps
        Next i
    End With
    
    'Colle le tableau dans excel
    Worksheets("Calcul").Range("I13:J156") = Tablo
    Application.ScreenUpdating = True
    End Sub
    1. Bonjour,

      Désolé pour ma réponse tardive, je ne pensai pas recevoir de réponse de votre part aussi vite !
      En effet, je n'avais pas pensé à regroupé les 2 journées dans la même boucle.
      Ça me permet de gagner 0,03 sec en moyenne, c'est toujours quelques secondes de gagné au final !

      Merci de votre aide en tout cas
  2. Contributeur
    Bonjour Sonoja,
    bonjour F89
    déjà commencer la macro par
    application.screenupdating=False
    'fige le défilement de l'écran: confort et rapidité


    gain de rapidité concernant P10
    remplacer
    ReDim P10(Fin - deb, 3)
    Dim j As Long

    For j = 0 To UBound(P10)
    P10(j, 0) = .Range("C" & j + deb) 'heure
    P10(j, 1) = .Range("D" & j + deb) 'puissance
    P10(j, 2) = .Range("F" & j + deb) 'jour
    P10(j, 3) = .Range("G" & j + deb) 'mois
    Next j

    par
    'déclaration de P10 ---> dim P10 sans parenthèse
    P10 = .Range(.Cells(deb, "C"), .Cells(Fin, "G"))

    attention P10 de base 1 au lieu de base 0

    je n'ai pas regardé après... cet aprem peut ^tre

    1. Bonjour,

      En effet si Tableau P10() un peu long, vaut mieux passer par votre code
    2. Bonjour merci de votre suggestion,

      Cependant, je n'ai pas besoin des informations continues dans la colonne "E". C'est pour ça que j'avais choisi de remplir mon tableau avec une boucle "for".
      J'avais essayé P10(,i)=.range... pour sélectionner les "colonnes" du tableau une par une. Mais ça ne fonctionne pas.
      Ça n'est peut être pas la bonne syntaxe.
    3. Modérateur
      @sonojaBonjour tout le monde,

      Une suggestion, toujours pour P10(), "volée" sur le site de Mr Boisgontier :

      Transfert d'un champ discontinu dans un tableau

      Sub test()
      Dim Colonnes, Nb As Integer, dl As Long, i As Long, lig As Long, Col As Long
      
          Colonnes = Array(3, 4, 6, 7) ' colonnes C, D, F, G
          Nb = UBound(Colonnes) + 1
          With Worksheets("10min")
              dl = derlig_reelle(.Cells)
              Dim P10(): ReDim P10(1 To Nb)
              For i = 1 To Nb
                  P10(i) = .Cells(1, Colonnes(i - 1)).Resize(dl).Value
              Next i
          End With
          lig = 3:  col = 4:  MsgBox P10(col)(lig, 1)
      End Sub
      
      Private Function derlig_reelle(plage As Range) As Long
         If WorksheetFunction.CountA(plage) = 0 Then derlig_reelle = 1: Exit Function
         derlig_reelle = plage.Find("*", , , , , xlPrevious).Row
      End Function


      Très rapide, moins de 0.10 secondes pour 65 000 lignes.
      Attention, au delà de 65 536 lignes cette méthode plante à cause de Application.Transpose!
      Autre dégât collatéral d'Application.Transpose, il transforme toutes données en String.
  3. Modérateur
    Il convient également de remplacer Application.Match par une autre méthode.
    Cela permet, au final, de regagner 5-6 secondes au total...

    Mieux que rien.
    Si vous êtes intéressé, faites le nous savoir.