Temps d'exécution très long car fichier lourd

Bonjour,

Voici le code que j'essaie d'appliquer à mon fichier :

Sub recherche()
Dim i&, j&, cj, cj1, ai, ai1, dj, bi, bi1, di, di1
  For i = 2 To Range("F2") + 1
    For j = 2 To Range("F2") + 1
      cj = Worksheets("Feuil1").Range("C" & j).Value
      cj1 = Worksheets("Feuil1").Range("C" & j + 1).Value
      ai = Worksheets("Feuil1").Range("A" & i).Value
      ai1 = Worksheets("Feuil1").Range("A" & i + 1).Value
      dj = Worksheets("Feuil1").Range("D" & j).Value
      bi = Worksheets("Feuil1").Range("B" & i).Value
      bi1 = Worksheets("Feuil1").Range("B" & i + 1).Value
    If Abs(ai - cj) < 0.000001 Then dj = bi Else If cj < ai And cj > ai1 Then dj = (bi + bi1) / 2
    Next j
  Next i

End Sub

Malheureusement il comporte 200 000 lignes et cela prend donc énormément de temps de le faire tourner (cela fait bien 30 minutes que j'attends son exécution...)

Ainsi, auriez-vous des idées pour réduire son temps d'exécution?

En vous remerciant.

Hello,

Essaie ça :

Sub recherche()

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual

Dim i&, j&, cj, cj1, ai, ai1, dj, bi, bi1, di, di1
  For i = 2 To Range("F2") + 1
    For j = 2 To Range("F2") + 1
      cj = Worksheets("Feuil1").Range("C" & j).Value
      cj1 = Worksheets("Feuil1").Range("C" & j + 1).Value
      ai = Worksheets("Feuil1").Range("A" & i).Value
      ai1 = Worksheets("Feuil1").Range("A" & i + 1).Value
      dj = Worksheets("Feuil1").Range("D" & j).Value
      bi = Worksheets("Feuil1").Range("B" & i).Value
      bi1 = Worksheets("Feuil1").Range("B" & i + 1).Value
    If Abs(ai - cj) < 0.000001 Then dj = bi Else If cj < ai And cj > ai1 Then dj = (bi + bi1) / 2
    Next j
  Next i

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

@+

Bonjour

Peut être un fichier a partager mais en rajoutant

application.screenupdating = false

application.calculation = xlmanual

En début de procédure et

Application.calculation = xlautomatic

Application.screenupdating = true

en fin de procédure ca devrait arranger un peu le temps d'exécution.

Merci pour vos suggestions ! Malheureusement même avec ces modifications, le temps d'exécution reste extrêmement long....

Auriez-vous d'autres suggestions d'optimisation/modification?

Voilà un fichier exemple du type de données utilisées :

Hello,

200000 lignes sur du VBA … 😂

Il faudrait peut être essayer d’autres solutions style PowerQuery :)

Si jai le temps je regarde ça sinon un autre Exceliens se fera un plaisir de regarder

@+

bonjour,

tu as 2 boucles imbriquées sur 200.000 lignes cela fait 40.000.000.000 de cas à traiter (normal que cela prenne du temps !). Si tu expliquais ce que tu essaies d'obtenir comme résultat ? le résultat final de tes calculs est une valeur en dj dont apparemment tu ne fais rien. J'ai donc un doute que le code corresponde à ce que tu veux faire.

Salut,

Sur 200 000 lignes ça prend un peu de temps mais ça se fait. Par contre je comprend pas l'utilité du code mais là c'est une autre histoire.

Il y a peut être moyen d'optimiser encore ça mais pour le moment je te propose ceci:

Option Explicit
Option Base 1
Sub recherche()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim tableau()
Dim i As Long, j As Long

tableau = Range(Cells(2, 1), Cells(Range("F2") + 1, 4))

  For i = LBound(tableau, 1) To UBound(tableau, 1)
    For j = LBound(tableau, 1) To UBound(tableau, 1)
    If Abs(tableau(i, 1) - tableau(j, 3)) < 0.000001 Then tableau(j, 4) = tableau(i, 2) Else If tableau(j, 3) < tableau(i, 1) And tableau(j, 3) > tableau(i + 1, 1) Then tableau(j, 4) = (tableau(i, 2) + tableau(i + 1, 2)) / 2
    Next j
  Next i

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Range("A2").Resize(UBound(tableau, 1), UBound(tableau, 2)) = tableau

End Sub

par contre je comprend pas pourquoi tu boucles deux fois dans le même tableau c'est pas 200 000 lignes que le code va traité mais 200 000 * 200 000

ça reste long surtout que tes données s'arrête à moins de 35 000 ligne

Merci pour vos réponses! Je tente vos solutions et vous tient au courant.

Le but de ce code est de "combler" de la donnée horodatée. En effet, j'aimerais avoir de la donnée toutes les 10 minutes mais par moment ce n'est pas le cas (1 donnée toutes les 20 ou 30 minutes).

bonsoir,

une proposition

Sub recherche()
    With Sheets("feuil1")
        dl = .Cells(Rows.Count, 1).End(xlUp).Row

'td tableau des données à corriger
        td = .Range("A1").Resize(dl, 2)

        datefin = .Cells(2, 1)
        datedebut = .Cells(dl, 1)
        min10 = 10 / 1440 '10 minutes

' tr tableau des données corrigées
        ReDim tr(1 To 200000, 1 To 2) 'max 200000 intervalles après ajout des intervalles manquants

        k = 1
        tr(1, 1) = "Date"
        tr(1, 2) = "New Y"
        For i = 2 To dl
            k = k + 1
            tr(k, 1) = td(i, 1) ' date et heure
            tr(k, 2) = td(i, 2) 'valeur Y
            If i < dl Then
                d1 = td(i, 1)
                d2 = td(i + 1, 1)
                m = (td(i, 2) + td(i + 1, 2)) / 2
                Do While d1 - min10 > d2
                    k = k + 1
                    d1 = d1 - min10
                    tr(k, 1) = d1 'date et heure corrigées
                    tr(k, 2) = m 'Y moyen sur l'intervalle
                Loop
            End If
        Next i
        .Range("C1").Resize(k, 2) = tr 'mettre tableau résultat en colonne C et D
    End With
End Sub