Macro lente et s'exécute la première fois seulement

Youssef -
michel_m Messages postés 18903 Date d'inscription Statut Contributeur Dernière intervention - 22 janv. 2018 à 11:14

Bonjour,

je viens vers vous pour m'aider à corriger le problème de lenteur d'une macro en phase exploitation

Il s'agit d'une mecro pour supprimer les lignes et les colonnes vides en sous total.

En utilisant la macro sur cinq feuilles dans le fichier excel (OF_MP_GM_1 à 5), ce dernier passe beaucoup de temps pour l'exécution.

Est-ce-que vous avez des améliorations à me proposer. Mille est un merci d'avance

Sub SupprimerSousTotalNul()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Set Feuille = ActiveSheet "Là pour revenir à la feuille d'accueil après l'exécution"

Sheets("OF_MP_GM_1").Select

'Recherche emplacement de Sous total
Set C = Rows("8").Find("S.Total.Commande", LookIn:=xlValues)
If C Is Nothing Then
MsgBox "La colonne ""S.Total.Commande"" est introuvable ou mal orthographiée"
Exit Sub
End If

Set L = Columns("A").Find("S.Total.Bobine", LookIn:=xlValues)
If L Is Nothing Then
MsgBox "La ligne ""S.Total.Bobine"" est introuvable ou mal orthographiée"
Exit Sub
End If

'recherche et suppression des 0 par lignes
For i = L.Row - 1 To 8 Step -1
If Cells(i, C.Column) = 0 Then Cells(i, C.Column).EntireRow.Delete
Next i

'recherche et suppression des 0 par colonnes
For i = C.Column - 1 To 3 Step -1
If Cells(L.Row, i) = 0 Then Range(Cells(8, i), Cells(L.Row, i)).Delete
Next i

Sheets("OF_MP_GM_2").Select

'Recherche emplacement de Sous total
Set C = Rows("8").Find("S.Total.Commande", LookIn:=xlValues)
If C Is Nothing Then
MsgBox "La colonne ""S.Total.Commande"" est introuvable ou mal orthographiée"
Exit Sub
End If

Set L = Columns("A").Find("S.Total.Bobine", LookIn:=xlValues)
If L Is Nothing Then
MsgBox "La ligne ""S.Total.Bobine"" est introuvable ou mal orthographiée"
Exit Sub
End If

'recherche et suppression des 0 par lignes
For i = L.Row - 1 To 8 Step -1
If Cells(i, C.Column) = 0 Then Cells(i, C.Column).EntireRow.Delete
Next i

'recherche et suppression des 0 par colonnes
For i = C.Column - 1 To 3 Step -1
If Cells(L.Row, i) = 0 Then Range(Cells(8, i), Cells(L.Row, i)).Delete
Next i

Sheets("OF_MP_GM_3").Select

'Recherche emplacement de Sous total
Set C = Rows("8").Find("S.Total.Commande", LookIn:=xlValues)
If C Is Nothing Then
MsgBox "La colonne ""S.Total.Commande"" est introuvable ou mal orthographiée"
Exit Sub
End If

Set L = Columns("A").Find("S.Total.Bobine", LookIn:=xlValues)
If L Is Nothing Then
MsgBox "La ligne ""S.Total.Bobine"" est introuvable ou mal orthographiée"
Exit Sub
End If

'recherche et suppression des 0 par lignes
For i = L.Row - 1 To 8 Step -1
If Cells(i, C.Column) = 0 Then Cells(i, C.Column).EntireRow.Delete
Next i

'recherche et suppression des 0 par colonnes
For i = C.Column - 1 To 3 Step -1
If Cells(L.Row, i) = 0 Then Range(Cells(8, i), Cells(L.Row, i)).Delete
Next i

Sheets("OF_MP_GM_4").Select

'Recherche emplacement de Sous total
Set C = Rows("8").Find("S.Total.Commande", LookIn:=xlValues)
If C Is Nothing Then
MsgBox "La colonne ""S.Total.Commande"" est introuvable ou mal orthographiée"
Exit Sub
End If

Set L = Columns("A").Find("S.Total.Bobine", LookIn:=xlValues)
If L Is Nothing Then
MsgBox "La ligne ""S.Total.Bobine"" est introuvable ou mal orthographiée"
Exit Sub
End If

'recherche et suppression des 0 par lignes
For i = L.Row - 1 To 8 Step -1
If Cells(i, C.Column) = 0 Then Cells(i, C.Column).EntireRow.Delete
Next i

'recherche et suppression des 0 par colonnes
For i = C.Column - 1 To 3 Step -1
If Cells(L.Row, i) = 0 Then Range(Cells(8, i), Cells(L.Row, i)).Delete
Next i

Sheets("OF_MP_GM_5").Select

'Recherche emplacement de Sous total
Set C = Rows("8").Find("S.Total.Commande", LookIn:=xlValues)
If C Is Nothing Then
MsgBox "La colonne ""S.Total.Commande"" est introuvable ou mal orthographiée"
Exit Sub
End If

Set L = Columns("A").Find("S.Total.Bobine", LookIn:=xlValues)
If L Is Nothing Then
MsgBox "La ligne ""S.Total.Bobine"" est introuvable ou mal orthographiée"
Exit Sub
End If

'recherche et suppression des 0 par lignes
For i = L.Row - 1 To 8 Step -1
If Cells(i, C.Column) = 0 Then Cells(i, C.Column).EntireRow.Delete
Next i

'recherche et suppression des 0 par colonnes
For i = C.Column - 1 To 3 Step -1
If Cells(L.Row, i) = 0 Then Range(Cells(8, i), Cells(L.Row, i)).Delete
Next i


Feuille.Select

MsgBox "Suppression des commandes nulles effectuée", 64
Exit Sub

Application.Calculation = xlCalculationAutomatic

End Sub

EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI

Merci d'y penser dans tes prochains messages.

Afficher la suite

2 réponses

Frenchie83 Messages postés 2254 Statut Membre 339

Bonjour,
Macro raccourcie, mais ne connaissant pas la taille de chaque feuille, je ne peux pas tester la rapidité d'exécution.

Sub SupprimerSousTotalNul()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Feuille = ActiveSheet.Name '"Là pour revenir à la feuille d'accueil après l'exécution"
    For i = 1 To 5
        Sheets("OF_MP_GM_" & i).Select
        Traitement
    Next i
    Sheets(Feuille).Select
    MsgBox "Suppression des commandes nulles effectuée"
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub Traitement()
    Application.ScreenUpdating = False
    'Recherche emplacement de Sous total
    Set C = Rows("5").Find("S.Total.Bobine", LookIn:=xlValues)
    If C Is Nothing Then
        MsgBox "La colonne ""S.Total.Bobine"" est introuvable ou mal orthographiée"
        Exit Sub
    End If

    Set L = Columns("A").Find("S.Total.Commande", LookIn:=xlValues)
    If L Is Nothing Then
        MsgBox "La ligne ""S.Total.Commande"" est introuvable ou mal orthographiée"
        Exit Sub
    End If
    
    'recherche et suppression des 0 par lignes
    For i = L.Row - 1 To 6 Step -1
        If Cells(i, C.Column) = 0 Then Cells(i, C.Column).EntireRow.Delete
    Next i
    
    'recherche et suppression des 0 par colonnes
    For i = C.Column - 1 To 2 Step -1
        If Cells(L.Row, i) = 0 Then Range(Cells(5, i), Cells(L.Row, i)).Delete
    Next i
End Sub

Cdlt

Réponse 2 / 2
michel_m Messages postés 18903 Date d'inscription Statut Contributeur Dernière intervention 3 320

Binjour

frenchie excuse l'inscruste

Youssef :
je n'ai pas compris l'intérêt de rechercher les sous totaux à la fin mais il est facile de relancer la sous macro "vérifier...."

Sans avoir le classeur sous les yeux ; j'ai travaillé " à l'aveugle" et donc, les erreurs sont probables; dans ce cas:
pour communiquer un classeur
Mettre le classeur sans données confidentielles en pièce jointe sur
https://mon-partage.fr/
Puis faire un clic droit copier le raccourci et coller dans votre message

code proposé dans ce classeur-maquette:
https://mon-partage.fr/f/WgLcKdvP/
0

Discussions similaires

une image de quelque seconde sur une vidéo

Paiement en 4 fois cdiscount

Vous avez essayé de vous connecter trop de fo

Imprimer 2 fois la même page (PDF) sur la même feuille

Savoir si quelqu'un a bloqué mon numéro

Forum VB / VBA

Newsletters

Newsletters

Actu du jour

Voir un exemple