Traitement macro , temps très long et énorme , blocage

Bonjour à tous,

je souhaite vos aides pour ce soucis

je vous joint un macro qui comporte 253000 lignes et qui a pour rôle de vérifier les dates d'arrêts s'ils sont continue ou discontinue , il rassemble les arrêts détecter en continue dans une seul ligne et surprime toutes lignes pour les arrêts inutiles

le soucis ce que le traitement prend une énorme de temps et un certain moment la macro bloque .

je ne sais pas s'il manque des codes ou le concept du macro en lui même n'est pas fiable qu'il prend se temps de traitement

je vous prie de vérifier et me tenir au courant si vous avez la solution pour moi .

pour infos je vous ai mis 50000 lignes car je ne peux pas uploader le fichier à 253000 lignes ( dépasse le 3 méga )

Bonsoir,

Au lieu de supprimer la ligne dans la boucle, mettez un "X" dans une colonne libre, puis à la fin, faites un filtrage sur cette colonne et supprimez toutes les lignes comportant un "X".

Ajoutez aussi:

"Application.Calculation = xlCalculationManual" après "Application.ScreenUpdating = False"

et en dernier:

Application.Calculation = xlCalculationAutomatic

Cdlt

Bonjour

Bonjour à tous

Un essai à tester. Le résultatt n'est pas instantané , mais peut-être te convient-il ?

Option Explicit

Dim timerAvant
Dim tablo, tabloR()
Dim i&, j&, k&, derLig&

Sub Controle()

    timerAvant = Timer
    Application.ScreenUpdating = False
    derLig = Range("D" & Rows.Count).End(xlUp).Row

    'Tri des données
    Range("A3:AB" & derLig).Sort _
            key1:=Range("D3"), order1:=xlAscending, _
            key2:=Range("H3"), order2:=xlAscending, _
            key3:=Range("J3"), order3:=xlAscending, _
            Header:=xlNo

    'On met le tableau dans une variable tableau pour une exécution
    'plus rapide et on initialise la feuille de calcul
    tablo = Range("A1:AB" & derLig)
    Range("A1:AB" & derLig).Offset(2, 0).ClearContents

    'On passe les dates en nombre pour éviter leur conversin en format américain
    For i = 3 To UBound(tablo, 1)
        tablo(i, 10) = DateValue(tablo(i, 10)) * 1
        tablo(i, 11) = DateValue(tablo(i, 11)) * 1
    Next i

    'Regroupement des congés
    k = 0
    For i = 3 To UBound(tablo, 1) - 1
            'Si matricule & motif absence sont identiques
            ReDim Preserve tabloR(1 To UBound(tablo, 2), 1 To k + 1)
            If tablo(i, 4) & tablo(i, 8) = _
                    tablo(i + 1, 4) & tablo(i + 1, 8) Then
                'On compare date début et date fin précédente
                'Si le nombre de jours ouvrés entre ces 2 dates est inférieur ou égal à 2,
                'alors on effectue le regroupement
                If Application.NetworkDays(CDate(tablo(i, 11)), CDate(tablo(i + 1, 10)), _
                        Range("JoursFeries")) <= 2 Then
                    tablo(i, 11) = tablo(i + 1, 11)
                    For j = 1 To UBound(tablo, 2)
                        tabloR(j, 1 + k) = tablo(i, j)
                    Next j
                    k = k + 1
                    i = i + 1   'on saute une ligne supplémentaire
                    GoTo suite
                Else
                    For j = 1 To UBound(tablo, 2)
                        tabloR(j, 1 + k) = tablo(i, j)
                    Next j
                    k = k + 1
                    GoTo suite
                End If
            Else
                For j = 1 To UBound(tablo, 2)
                    tabloR(j, 1 + k) = tablo(i, j)
                Next j
                k = k + 1
            End If
suite:
    Next i

    'On reporte le nouveau tablo sur la feuille de calcul
    Range("A3").Resize(UBound(tabloR, 2), UBound(tablo, 2)) = Application.Transpose(tabloR)
    Application.CutCopyMode = False

     'Affichage de la durée de la procédure
    MsgBox "Temps d'exécution : " & Timer - timerAvant & " secondes."

End Sub

Bye !

Bonjour,

merci gmb et Arturo83

je vais tester vos deux propositions et je reviens vers vous dés que possible .

A bientôt

bonjour,

gmb ton code :

1- efface les matricules, le motif d'arrêt et la date début sur toutes les lignes et ne laisse aucune trace

2 - la date fin est en format nombre

donc il y a un soucis quelque part

Bonjour,

la solution de Arturo83 es plus tôt meilleur , temps d'exécution 28 secondes

le soucis se pose sur la suppression de ligne , très bloquant et long

Sub SupprimerLignesSiColonneMX()
    Dim ws As Worksheet
    Set ws = ActiveSheet 'Definit la feuille de travail active
    Dim lastRow As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    lastRow = ws.Cells(ws.Rows.Count, "M").End(xlUp).Row 'Trouver la dernière ligne avec des données dans la colonne M

    Dim row As Long
    'Boucle descendante pour supprimer les lignes de la fin vers le début
    For row = lastRow To 3 Step -1 'Commence par la dernière ligne et remonte jusqu'à la 3ème ligne
        If ws.Cells(row, "M").Value = "X" Then 'Vérifie si la cellule dans la colonne M est égale à "X"
            ws.Rows(row).Delete 'Supprime la ligne si la condition est vraie
        End If
    Next row

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Bonjour,

Je n'ai pas écrit de supprimer les lignes une par une, mais en une seule fois, pour cela filtrez la colonne des "X "

et copiez ceci pour tout supprimer en une seule fois:

ActiveSheet.Rows("2:" & DerLig).SpecialCells(xlCellTypeVisible).Delete

Cdlt

bonjour le fil,

@Arturo83, je n'en suis pas sûr, mais dans le temps, il y avait un problème avec le nombre d' "areas" qu'on supprime en même temps. Je pense que cela est limité à 16.000 (ou 32.000 ???) à la fois et en supposant qu'on a en alternance d'une ligne à supprimer et d'une ligne à conserver, je pense qu'il faut faire cela en blocs de 32.000 (ou 64.000 ???) lignes.

Donc 253.000 lignes /32000 = en 8 blocs et on le fait "descendant" >>> bloc 1 = 221.000 à 253.000, bloc 3 = 189.000 à 221.000 etc .

je pense que c'est peut-être aussi une optimalisation de la vitesse, à voir, ... que 253 blocs de 1.000 lignes sera plus vite que ces 8 bloc d'ici dessus.

Peut-être demander à ghazi17 de compter le nombre d' "areas" dans sa colonne M

@Arturo83 , le rôle de ce code ( ActiveSheet.Rows("2:" & DerLig).SpecialCells(xlCellTypeVisible).Delete ) d'effacer le contenu des lignes préférées

par contre pour supprimer les lignes entière c'est ce code ( ActiveSheet.Rows("2:" & DerLig).Delete ) => temps de suppression de 102000 lignes = 2 secondes

Grâce Arturo83 le sujet est résolu = temps de traitement ( contrôle des arrêts 28 secondes et suppression des lignes = 2 secondes pour un total de 30 secondes ).

c'est plus que parfait .

merci @Arturo83