Ralentissement de l'exécution d'une macro [Résolu/Fermé]

Signaler
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
-
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
-
Bonjours à tous!

J'ai un problème avec une macro que j'utilise pour faire un tri mes données et les copie dans une autres feuilles selon leur type. La macro fonctionnais très bien et rapidement avec ma feuille test mais dès que je la vide et que je recommence à zéro avec de nouvelles données c'est très lent.

Je n'y comprend rien!

La macro se lance avec le bouton mettre à jours les feuillets sur la page "Accueil" et lorsque j'ouvre la fichier si la cellule "A5" est non vide.

Voici mon code principale:
Sub CopieFeuillets()
' Macro de Copie & de Tri

Dim f As Worksheet

Application.ScreenUpdating = False

For Each f In ActiveWorkbook.Worksheets
    f.Unprotect
Next

   With Sheets("Coordonnées")
  
        For i = 1 To 4
            On Error Resume Next
            Erase critères
            On Error GoTo 0
            Select Case i
            
            Case 1
                wsn = "FORAGE"
                critères = Array("F", "FC", "FS", "FSZ")
                Col = "A" ' colonne dans laquelle mettre le n° de sondage, est également la colonne pour le tri
               PL = 8 'première ligne des données dans wsn
               tabtri = "A" & PL & ":N" ' tableau à trier
           Case 2
                wsn = "CPTU"
                critères = Array("C", "CR", "FC", "M")
                Col = "A"
                PL = 7
                tabtri = "A" & PL & ":O"
            Case 3
                wsn = "Piézomètres"
                critères = Array("Z", "FSZ")
                Col = "B"
                PL = 8
                tabtri = "A" & PL & ":M"
            Case 4
                wsn = "Inclinomètres"
                critères = Array("I")
                Col = "B"
                PL = 7
                tabtri = "A" & PL & ":H"
            End Select
           
            .Range("$A$4:$N$64").AutoFilter Field:=4, Criteria1:=critères, Operator:=xlFilterValues         'on filtre les données de coordonnées
           
           Set ws = Sheets(wsn)    ' ws = référence de la feuille
           nl = ws.Cells(Rows.Count, Col).End(xlUp).Row    ' nl pointeur de dernière ligne utilisée dans la feuille basé sur colonne col
           If nl < PL Then nl = PL + 1
            For Each r In .Range(.Range("C5"), .Range("C5").End(xlDown)).SpecialCells(xlVisible)    ' on parcourt toutes les cellules sélectionnées de la colonne  C, (r=cellule en cours)
               Set re = ws.Range(Col & ":" & Col).Find(r.Value, lookat:=xlWhole)    'on recherche le n°de sondage dans la colonne col
               If re Is Nothing Then    'si non trouvé
                    'ajoute une nouvelle ligne avant derniere ligne
                    ws.Rows(nl).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    'derniere ligne + 1
                    ws.Cells(nl, Col) = ws.Cells(nl - 1, Col)
                    ws.Cells(nl - 1, Col) = r.Value  ' on met le numéro de sondage en colonne col
               End If
            Next
            With ws.Range(tabtri & nl)
                .Sort key1:=.Cells(1, Col), order1:=xlAscending, Header:=xlNo
            End With
        Next i
        If Worksheets("Coordonnées").AutoFilterMode Then
            Worksheets("Coordonnées").AutoFilterMode = False
        End If
    End With
    

For Each f In ActiveWorkbook.Worksheets
    f.Protect
Next
    
Application.EnableEvents = True

End Sub

J'ai aussi une macro sur ma feuille destination:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim T As Range, i&
Set T = [Tableau5]
Application.EnableEvents = False
On Error Resume Next 'sécurité
If T.Rows.Count < 4 Then
  Application.Undo 'annulation
Else
  '---suppression des lignes vides---
  For i = T.Rows.Count - 1 To 4 Step -1
    If T(i, 1) = "" Then T(i, 1).EntireRow.Delete
  Next
  '---ajout de ligne---
  If T(T.Rows.Count, 1) <> "" Then
    Application.ScreenUpdating = False
    T(T.Rows.Count, 1).EntireRow.Insert
    T.Rows(T.Rows.Count - 1).FormulaR1C1 = T.Rows(T.Rows.Count).FormulaR1C1
    T.Rows(T.Rows.Count) = ""
    Application.ScreenUpdating = True
  End If
End If

End Sub

Pouvez-vous m'aider?

Je joint aussi mon fichier: http://cjoint.com/?0Eird3REtmw

Merci!

1 réponse

Messages postés
15731
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
14 avril 2021
1 481
Bonjour,

Onglet coordonnees, pas de Type dans cellule dernier dossier, boucle de 1048512 tours pour Inclinometre.

fichier modifie si criteres n'existent pas: https://www.cjoint.com/c/EEjkuEAXO4I
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
1
Merci beaucoup pour ta réponse f894009!

Tous semble fonctionner, mais j'ai une petite question.

Le message qu'il envoie: "C'est critères:<I;> n'existe pas!!!!!", c'est juste pour une vérification??

Ou ça veut dire que j'ai un problème?

Encore merci!
Messages postés
15731
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
14 avril 2021
1 481 >
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021

Bonjour,

"C'est critères:<I;> n'existe pas!!!!!" Dans votre onglet coordonnees, a la derniere ligne il manque le type et les autres types ne sont pas "I", donc message comme quoi y en a pas. Ce messsage est valable pour toutes les recherches
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
1 >
Messages postés
15731
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
14 avril 2021

Merci pour la réponse!

Je comprend bien maintenant!