XL 2016 Simplifier macro rapidité

[ghosts11111]

Bonjour à tous,
je souhaite simplifier une macro qui aujourd'hui me prend énormément de temps. le but de la macro est de récupérer les affectations de 300 personnes par services en fonction d'une base de données de 18000 lignes.
La macro initiale fonctionne rapidement mais en 2ème partie je demande à la macro de me supprimer toutes les lignes ayant une affectation à 0h et là il met un temps fou.
Merci à vous si une simplification est possible.

code :

Sub CréerAffectations()

Application.ScreenUpdating = False

Dim Base As Range, Personnels As Range, Personnel As Range, Destination As Range
Dim LoAffectations As ListObject

'compteur temps
Dim debut As Date, temps As Date, fin As Date
debut = Time

'suppression base avant création

Sheets("Affectations").Activate

Rows("2:10000").Select
Selection.Delete Shift:=xlUp

' initialisation des variables de travail

With ThisWorkbook

    Set Base = .Sheets("Base").Range("T_Base")
    Set Personnels = .Sheets("Base personnel").Range("T_BasePersonnel")
    Set LoAffectations = .Sheets("Affectations").ListObjects("T_Affectations")

End With

' Pour chaque ligne de personnel

For Each Personnel In Personnels.Rows()

' Vérifier que le personnel en cours de boucle n'est pas déjà dans le tableau des affectations

    If Not IsError(Application.Match(Personnel.Cells(1, 1), LoAffectations.Range.Columns(2), 0)) Then

           ' S'il l'est, demander s'il faut continuer ou passer au prochain
       If MsgBox(Personnel.Cells(1, 2) & " existe déjà dans le tableau des affectations !" & vbCrLf & _
                "Continuer et l'ajouter de nouveau ?", vbQuestion + vbYesNo, "Affectation personnel") = vbNo Then GoTo Prochain

    End If

    ' définir la destination de la copie de données

    If Not LoAffectations.InsertRowRange Is Nothing Then

        ' La ligne d'insertion automatique existe, on la retient
        Set Destination = LoAffectations.InsertRowRange

    Else

        ' Elle n'existe pas, on la crée
        Set Destination = LoAffectations.ListRows.Add().Range

    End If

    ' Copie des données de base dans la destination

    Base.Copy Destination

    ' copie des données particulières dans les colonnes

    With Destination.Resize(Base.Rows.Count)
        .Columns(1).Value = Personnel.Cells(1, 5).Value '   Fonction
        .Columns(2).Value = Personnel.Cells(1, 1).Value '   Matricule
        .Columns(3).Value = Personnel.Cells(1, 2).Value '   Nom
    End With   

Prochain:
Next Personnel

Application.CutCopyMode = False

'supprime toutes les lignes à 0h
Sheets("Affectations").Activate

    For Z = 10000 To 2 Step -1 'ligne du tableau
        If Cells(Z, 7) = "0" Then 'mot recherché qui supprime la ligne
            Rows(Z).Delete
        End If
    Next Z

'fin suppression ligne à 0h

'module temps fin + box message

fin = Time
temps = fin - debut

MsgBox ("C'est fini !" & Chr(10) & "temps de traitement " & temps)
MsgBox "Fichier prêt"

End Sub

 

[Etoto]

Bonjour,

Je viens pour te dire de mettre ton code dans une balise pour le rendre plus visible.

EDIT : Super merci

Cordialement

 

[ChTi160]

Bonjour ghosts11111
Bonjour le Fil,le Forum
Tu pourrais aussi pour gagner en rapidité passer par un tableau temporaire plutôt que de boucler sur les cellules !
Bonne journée
Jean marie

 

[Valtrase]

Salut à tous
Remarque 1:
Tu pourrais créer un paramètre qui te permet d'éviter de devoir confirmer à chaque fois si on conserve ou pas.

Concernant la rapidité de ton code comme le dis si bien Chti160 Passes par un tableau c'est nettement plus rapide inspires toi des très bon exemple de Jacques Boigontier

 

[sylvanu]

Bonjour Ghosts, Chti, Valtrase, Etoto,
Un essai en PJ pour la seconde partie avec :

Sub SupprimerLignes()
    Application.ScreenUpdating = False
    Columns(8).EntireColumn.Insert: Columns(8).Select
    tablo = Range("G1:G" & Range("C65500").End(xlUp).Row)
    For i = 1 To UBound(tablo)
        If tablo(i, 1) = 0 Then Cells(i, "H") = Chr(1)
    Next i
    Columns(8).EntireRow.Sort Columns(8).Cells, xlDescending  'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    Columns(8).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
    Columns(8).Delete Shift:=xlToLeft
End Sub

Lancer la macro MacroTest.
Sur mon PC, sur 10k lignes j'ai :

soit trois fois plus rapide.

 

[ChTi160]

Re
Sans fichier pas évident ! Non ?

Pour éviter de supprimer des Lignes entières de la feuille "Affectations" , on pourrait définir la plage a effacer .

'suppression base avant création
With Sheets("Affectations")
    Derlgn = .Cells(.Rows.Count, 1).End(xlUp).Row
  If Derlgn > 1 Then 'si rien dans la feuille
    DerCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
      .Range(.Cells(2, 1), .Cells(Derlgn, DerCol)).ClearContents
  End If
End With

Bonne journée
jean marie

 

[mapomme]

Bonjour à tous,

Le minimum syndical serait de nous fournir un classeur.

 

[ChTi160]

arff les syndicats lol
c'est plus ce que c'était Lol
bon je vais attendre d'en savoir un peu plus "Nombre de services" etc etc
un fichier sans données confidentielles , quelques lignes un exemple de ce qui est voulu devrait , aider !
jean marie

 

[ghosts11111]

Merci à tous pour vos réponses rapides. j'ai pu en effet en passant par un tableau gagner du temps sur le traitement.
Désolé pour le fichier, la prochaine fois je prendrai le temps de faire un exemple avec données fictives.

Bonne journée à tous

 

[ChTi160]

Re
Ben ça était rapide non ?
Un conseil a suffit lol
Jean marie