XL 2016 Simplifier macro rapidité

ghosts11111

XLDnaute Nouveau
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 :

VB:
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
 
Dernière édition:
Solution
Bonjour Ghosts, Chti, Valtrase, Etoto,
Un essai en PJ pour la seconde partie avec :
VB:
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 :
1624359194268.png

soit trois fois plus rapide.

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Ghosts, Chti, Valtrase, Etoto,
Un essai en PJ pour la seconde partie avec :
VB:
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 :
1624359194268.png

soit trois fois plus rapide.
 

Pièces jointes

  • Ghosts4.xlsm
    184.5 KB · Affichages: 10

ChTi160

XLDnaute Barbatruc
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 .
VB:
'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
 

ghosts11111

XLDnaute Nouveau
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
 

Discussions similaires

Réponses
28
Affichages
921

Statistiques des forums

Discussions
311 720
Messages
2 081 909
Membres
101 836
dernier inscrit
karmon