Evenement à la fermeture que j'aimerais conditionner a une modification

Le 16/02/2021 à 15:47

Bonjour a tous,

alors voila, je suis toujours sur mon fichier/ programme.

maintenant que j'ai ma validation des heures, l exclusion des week end, l'alerte quand on est au dessus du quota, ...

et apres avoir transcrit mon autres tableau en version 2013 pour ajout evenement outlook, ... (j ai l impression que j'accumule les demandes chiantes et complexe)

alors voila j'ai ecris ce code (avec mes humbles moyens et connaissances)

qui a pour but de trier, mettre a jour les formule (car lors du tri la reference en A n'etait plus correcte sur ma colonne C), puis de copie la premiere ligne sur une page archive, puis supprimer les lignes copiées.

tout marche (yahouuu)

le probleme cest que quand je n'ai pas d'ajout de donnée, le tri se fait quand meme, et entraine un probleme de debogueur, pareil pour la copie et suppression, sans parler de la lenteur de la macro,

j'aimerais donc conditionner l'evenement de cloture du workbook, a une modif quelconque sur une des feuille

je pensais faire quelque chose comme un evenemnt sur chaque feuille qui me renverrai vrai quand je fais une modif ou ajout d'une ligne, puis une fonction sur le workbook qui dirait si une des fonction renvoie true, alors j'effectue mon evenemnent, mais si aucune ne renvoie true, alors je ferme le fichier sans rien effectuer.

vous pensez que c'est jouable facilement? et si oui comment.? je prend volontier les explications avec des commentaires dans vos codes ;)

merci d avance

Private Sub Workbook_BeforeClose(Cancel As Boolean)
' a la fermeture du classeur

' met en arret la maj de l ecrant (accelere la macro)

Application.ScreenUpdating = False

' tri la page suivi BT (facturé, soldé, en cours)

    Cells.Select
    ActiveWorkbook.Worksheets("suivi des BT").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("suivi des BT").Sort.SortFields.Add Key:=Range( _
        "H2:H1771"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("suivi des BT").Sort.SortFields.Add Key:=Range( _
        "F2:F1771"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("suivi des BT").Sort.SortFields.Add Key:=Range( _
        "A2:A1771"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("suivi des BT").Sort
        .SetRange Range("A1:H1771")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' met a jour la formule du cout apres le tri colonne MO

     Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C919"), Type:=xlFillDefault
    Range("C2:C919").Select

   ' met a jour la formule du cout apres le tri colonne materiel
  Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D919"), Type:=xlFillDefault
    Range("D2:D919").Select

'copie les ligne des BPU marqués "facturés" sur la feuille "archive"
With Sheets("BPU")
i = 2
    Do While Cells(i, 5) <> ""
        .Range(Cells(i, 1), Cells(i, 8)).Copy Destination:=Sheets("Archives annuelles").Cells(Rows.Count, 1).End(xlUp)(2)
    i = i + 1

    Loop
End With
'supprime les lignes copiées dans "archives"

With Sheets("suivi des BT")
i = 2
    Do While Cells(i, 8) <> ""
        .Range(Cells(i, 1), Cells(i, 8)).Delete

    i = i + 1

    Loop
End With

'copie les ligne des BT marqués "facturés" sur la feuille "archive"
With Sheets("suivi des BT")
i = 2
    Do While Cells(i, 8) <> ""
        .Range(Cells(i, 1), Cells(i, 8)).Copy Destination:=Sheets("Archives annuelles").Cells(Rows.Count, 1).End(xlUp)(2)
    i = i + 1

    Loop
End With
'supprime les lignes copiées dans "archives"

With Sheets("suivi des BT")
i = 2
    Do While Cells(i, 8) <> ""
        .Range(Cells(i, 1), Cells(i, 8)).Delete

    i = i + 1

    Loop
End With

'remet en route la mise a jour de l ecran

Application.ScreenUpdating = True

End Sub
18essai.zip (144.12 Ko)
Le 16/02/2021 à 16:22

Bonjour,

Voici une première proposition d'adaptation du code (si je l'ai bien compris) :

Private Sub Workbook_BeforeClose(Cancel As Boolean)
if maconditionestremplie then call Archivage
end sub

sub Archivage()

Application.ScreenUpdating = False
with ActiveWorkbook.Worksheets("suivi des BT")
    with .Range("A1:H1771").Sort
        .SortFields.Clear
        .SortFields.Add Key:=.Range("H2:H1771"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=.Range("F2:F1771"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=.Range("A2:A1771"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    end with
    .Range("C2").AutoFill Destination:=.Range("C2:C1771"), Type:=xlFillDefault
    .Range("D2").AutoFill Destination:=.Range("D2:D1771"), Type:=xlFillDefault
End With

'copie BPU - colle dans archives - supprime BPU
With Sheets("BPU")
    dl = .cells(.rows.count, 5).end(xlup).row
    if dl > 1 then
        t = .range("A2:H" & dl).value
        with Sheets("Archives annuelles")
            nvl = .Cells(.Rows.Count, 1).End(xlUp).row + 1
            .cells(nvl, 1).resize(ubound(t), ubound(t,2)).value = t
        end with
        .range("A2:H" & dl).clear
    end if
End With

'copie suivi BT - colle dans archives - supprime suivi BT
With Sheets("suivi des BT")
    dl = .cells(.rows.count, 5).end(xlup).row
    if dl > 1 then
        t = .range("A2:H" & dl).value
        with Sheets("Archives annuelles")
            nvl = .Cells(.Rows.Count, 1).End(xlUp).row + 1
            .cells(nvl, 1).resize(ubound(t), ubound(t,2)).value = t
        end with
        .range("A2:H" & dl).clear
    end if
End With
Application.ScreenUpdating = True

End Sub

Remarques :

Dans le code, il faut éviter les select qui le ralentissent considérablement et en rendent la lecture difficile.

Vous avez une plage A1:H1771. Or, il semble que précédemment, cette plage n'allait que jusqu'à la ligne 919. Il faut absolument mettre les données de suivi BT sous forme de tableau structuré. Ca rendra le code dynamique et facilitera bien des opérations !

D'ailleurs, il faut mettre chaque tableau sous forme de tableau structuré...

Il faut éviter l'enchainement des boucles (surtout lorsqu'elles sont redondantes ou improductives). En effet, dans le code, vous supprimez les lignes de BT, puis vous les copiez puis vous les supprimez. En réalité, enfin j'en ai l'impression, il ne se passe rien à part la suppression.

Il faut essayer de copier en valeur, si possible à l'aide d'arrays (tableaux dynamiques de VBA) pour accélérer l'exécution du code.

Je n'ai pas regardé le fichier donc on est pas à l'abri d'une mauvaise compréhension de ma part et il est possible qu'un bug survienne sur la partie du tri...

Cdlt,

Rechercher des sujets similaires à "evenement fermeture que aimerais conditionner modification"