Microsoft 365 optimisation d'un programme en utilisant la fonction Array

[Thomas_1]

Bonjours à toutes et tous.

J'ai créé un programme qui me permet d'effacer les lignes que je n'utilise pas. Après avoir réussi à créer ce programme je me suis aperçu qu'il mettait plusieurs heures à s'exécuter (le fichier fait 110 000 lignes) . Suite à quelques recherches j'ai trouvé plusieurs astuces pour optimiser celui-ci dont l'utilisation de la fonction Array mais je n'arrive pas à l'adapter à mon code. Est ce que quelqu'un pourrait m'aider s'il vous plaît ?

Le code complet est :
Sub delete()

Dim line As Long
Dim x As Long
Dim difference As Long
Dim datarange As Variant

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

'Read all datas in the table
line = Range("A" & Rows.Count).End(xlUp).Row
datarange = ActiveSheet.Range("A2:A" & line).Value

'Delete rows that I won't use in the table
For x = 2 To line
If Cells(x + 1, 1) - Cells(x, 1) < 694 Then
datarange.Rows(x + 1).Delete
Else
x = x + 1
End If
x = x - 1
Next x

'Transcribe all datas in the Excel sheet
Range("A2:A" & line).Value = datarange

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[crocrocro]

Bonjour Thomas
voici le code avec 2 macros :
la 1ère pour initialiser une feuilles avec 100 000 lignes pour le test
la 2ème correspond à votre "Delete", ici je test pour une différence entre la ligne et la ligne suivante = 1000
A Noter que la boucle commence par la dernière ligne en remontant !
Le Delete dure 2 minutes 30 sur mon PC peu performant (voir MsgBox)

Sub InitLignes()
Dim i As Long
    For i = 1 To 100000
        If i Mod 2 = 0 Then
            Cells(i, 1) = i + 1001
        Else
            Cells(i, 1) = i
        End If
    Next i
End Sub
Sub DeleteLignes()
Dim l As Long
Dim Nlig As Long
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    t1 = Timer
    Nlig = Range("A" & Rows.Count).End(xlUp).Row
   For l = Nlig - 1 To 1 Step -1
      If Cells(l + 1, 1) - Cells(l, 1) < 1000 Then
          Rows(l + 1).Delete
      End If
   Next
   t2 = Timer
   Application.ScreenUpdating = True
    Application.EnableEvents = True
   MsgBox " durée : " & t2 - t1
 
End Sub

 

[Dranreb]

Bonsoir.
Un tableau n'étant pas un objet, il ne possède ni propriété ni méthode, en particulier pas de méthode Delete. Tout ce qu'on peut faire c'est y déplacer les valeurs à garder.

Sub Delete()
   Dim Rng As Range, T(), LE As Long, LS As Long
   Set Rng = ActiveSheet.[A2].Resize(ActiveSheet.[A1000000].End(xlUp).Row - 1)
   T = Rng.Value
   LS = 1
   For LE = 2 To UBound(T, 1)
      If T(LE, 1) - T(LE - 1, 1) >= 694 Then
         LS = LS + 1
         T(LS, 1) = T(LE, 1)
         End If
      Next LE
   While LS < UBound(T, 1): LS = LS + 1: T(LS, 1) = Empty: Wend
   Rng.Value = T
   End Sub

 

[patricktoulon]

bonsoir
en voila une drôle de question
j'ai testé diverses méthode
et j'en arrive a une conclusion tu nous a pas tout dit
notamment que quand une/des valeurs ne saute(nt) pas on se retrouve à la fin avec des cellules qui se suivent et dont le resultat de la soustraction passe en dessous le 694

d'autant plus que dès que l'on va tomber sur un nombre < 694 en cellule (x,1)
c'est fini pour le reste
puisque le resultat de la soustraction de la cellule (x+1,1)-cellule(x,1)sera toujours en dessous 694
Alors que fait on?
a mon avis tu va te rendre compte que ce n'est tout a fait ce que tu veux

 

[TooFatBoy]

Bonjour,

Je me demande si tu n'as pas oublié d'actualiser la valeur de fin de ta boucle FOR après la suppression d'une ligne, ce qui diminuerait peut-être la durée de traitement de ta macro ?

Sub Supprimer()
'
Dim ligne As Long
Dim x As Long
Dim difference As Long
'Dim datarange As Variant

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    ' Read all datas in the table
    ligne = Range("A" & Rows.Count).End(xlUp).Row
'    datarange = ActiveSheet.Range("A2:A" & line).Value

    ' Delete rows that I won't use in the table
    x = 2
    While x < ligne
        If Cells(x + 1, 1) - Cells(x, 1) < 694 Then
            Cells.Rows(x + 1).delete
            ligne = ligne - 1
        Else
            x = x + 1
        End If
    Wend

    ' Transcribe all datas in the Excel sheet
'    Range("A2:A" & line).Value = datarange

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

End Sub

---

j'en arrive a une conclusion tu nous a pas tout dit
notamment que quand une/des valeurs ne saute(nt) pas on se retrouve à la fin avec des cellules qui se suivent et dont le resultat de la soustraction passe en dessous le 694

Normalement non, puisque si le résultat de la soustraction est inférieur à 694, on supprime la ligne x+1.

d'autant plus que dès que l'on va tomber sur un nombre < 694 en cellule (x,1)
c'est fini pour le reste
puisque le resultat de la soustraction de la cellule (x+1,1)-cellule(x,1)sera toujours en dessous 694

T'es sûr de ça ?

Si en cellule (x,1) on 4 (qui est un nombre < 694) et qu'en cellule (x+1,1) on a 1000, le résultat de la soustraction de la cellule (x+1,1)-cellule(x,1) donne 996, qui n'est pas en-dessous de 694.

 

[Thomas_1]

Bonjours à tous. J'ai essayé tous les programmes que vous m'avez et il fonctionne tous parfaitement. Merci beaucoup pour votre aide !