Chronometrer une procédure

Bonjour,

Pour la procédure suivante, je souhaiterais afficher soit un chronomètre ou une barre de progression

En fait l'idéal serait de connaitre la durée de la procédure afin d'afficher un décompte soit par un "compte à rebours ou une barre de progression

POurriez vous m'aider svp

merci par avance

Private Sub CommandButton2_Click()
    Dim f As Worksheet, ln%, lgn%, n%, i%, a%
    Set f = Worksheets("Feuil2")
    f.Range("A1").CurrentRegion.Offset(2).Clear
    lgn = 3
    Application.ScreenUpdating = False
    With Me
        For ln = 3 To .Range("A" & .Rows.Count).End(xlUp).Row
            a = Year(.Range("D" & ln)): n = Year(.Range("G" & ln)) - a
            .Range("A" & ln & ":AE" & ln).Copy f.Range("A" & lgn & ":A" & lgn + n)
            For i = 0 To n
                f.Range("O" & lgn + i) = a + i
            Next i
            lgn = lgn + n + 1
        Next ln
    End With
    f.Activate
End Sub

Bonjour,

Voici une procédure à adapter à ton cas ...

Merci pour ta réponse

petite précision,

je dois l'insérer dans ma procédure ou en créer une en parallèle ?

Dans ce cas les 2 procédures doivent être lancées en même temps...

Merci d'avance

Je ne connais pas ton niveau en VBA.

Je vais essayer d'expliquer (sinon mets en ligne ton code complet avec un extrait anonymisé de données)

Tu dois recopier la feuille BarreProgressionet le module ModBarreProgression

Ensuite tu dois fusionner ton code avec celui-ci :

Sub Votre_Routine()

    timedebut = Now()

    Application.ScreenUpdating = False
    BarreProgression.Show vbModeless

    ' à customiser ==================================
    BarreProgression.Caption = "test"

    For compteur = 0 To 100 Step 5
        BarreDeProgression compteur / 100
        Application.Wait (Now + TimeValue("0:00:01"))
    Next
    ' ===============================================

    Unload BarreProgression

    MsgBox ("Terminé en " & Format((Now() - timedebut), "n' ss''") & " !")

End Sub

Mon niveau n'est vraiment pas terrible ...

j ai essayé de fusionner les codes et j'ai placé ton code au début de ma procédure

mais visiblement ce n'est pas aussi simple

j'ai joint le fichier avec les données comme tu me l'as demandé

Pour info ma procédure s'exécute environ en 2mns30 environ lorsqu' il y a toutes les données ( oui c'est long ! )

encore merci pour ton aide

En voulant copier le module ModBarreProgression j ai un message d'erreur qui s'affiche :

"Erreur de compilation

Le code de ce projet doit être mis à jour pour pouvoir être utilisé sur les systèmes 64 bits.

Vérifiez et mettez à jour les instructions Declare , puis marquez les avec l'attribut PtrSafe."

???

Merci

Pour le message d'erreur, j ai trouvé la solution

merci

Ah ! le fait est que je suis aussi en 64 bits et que je n'ai pas de soucis ...

ok je regarde ton fichier ...

Voici,

dis moi si le résultat te convient

j'ai mis en exergue les ajouts à ta procédure et ajouté la feuille et le module cité ci-avant

Merci c'est ce que je souhaitais et le fichier test fonctionne très bien !

Par contre en apportant les modifications dans le fichier original avec beaucoup plus de données le code bug (

Du fait du nombre de données ?

Je vais faire des recherches et si je n'y arrive pas je te solliciterai de nouveau stp

merci encore

Curieux !

Combien de données ?

Mets petit à petit par paquet de 100 lignes ...

Désolé pour ma réponse tardive pour cause de réunion...

En effet c'est curieux.

Explications.

La procédure doit traitée environ 1400 lignes

j ai fais un test : Si j'exécute la procédure sur mon PC directement cela fonctionne et le traitement des 1400 lignes se fait impeccable

Par contre si je le fais sur le réseau via notre serveur professionnel c'est là qu'il bug ...

Je vous ai remis le code en indiquant la ligne qui bug

Ne s'agit il pas d'un problème de version 32 ou 64 bits???

Merci et désolé de vous embêter avec cela (

Option Explicit

Dim f, ln, lgn, n, i, ret
' ajout =
Dim timedebut

Private Sub CommandButton2_Click()

' ajout
    timedebut = Now()
    Application.ScreenUpdating = False
    BarreProgression.Show vbModeless
' fin ajout

    Application.ScreenUpdating = False
    Call MAJ_Feuil2
    Set f = Sheets("Feuil2")
    f.Range("A1").CurrentRegion.Offset(3, 0).Clear
    For ln = 3 To Range("A" & Rows.Count).End(xlUp).Row

    ' ajout
        BarreDeProgression ln / Range("A" & Rows.Count).End(xlUp).Row
    ' fin ajout

        n = Year(Range("G" & ln)) - Year(Range("D" & ln)) + 1
        lgn = Application.Max(3, f.Range("A" & Rows.Count).End(xlUp)(2).Row)
        Range("A" & ln & ":AE" & ln).Copy
        f.Range("A" & lgn & ":AE" & lgn + n - 1).PasteSpecial xlPasteAll ' c'est cette ligne qui bug
        For i = 0 To n - 1
            f.Range("O" & lgn + i) = Year(f.Range("D" & lgn)) + i
        Next i
    Next ln
    Application.CutCopyMode = False
    f.Select

' ajout
    Unload BarreProgression
    MsgBox ("Terminé en " & Format((Now() - timedebut), "n' ss''") & " !")
' fin ajout

    MsgBox "Actualisation réussie!", vbInformation

End Sub

... et donc logiquement cette ligne

f.Range("A" & lgn & ":AE" & lgn + n - 1).PasteSpecial xlPasteAll ' c'est cette ligne qui bug

doit aussi bugger à l'origine car elle provient de ta procédure et la progress bar n'a pas d'interférence a priori avec elle.

Essaye sans les ajouts et sur le réseau !!

Je ne pourrai pas te donner la solution ... désolé.

Bonjour,

Effectivement je suis aussi convaincu qu'il s'agit d'un soucis lié au réseau car sans les ajouts la procédure fonctionne sur le réseau...

Je vais faire des tests et tenter de trouver la solution.

Merci encore pour ta précieuse aide

En te souhaitant une excellente journée

bien cordialement

A toi de cliquer sur le symbole ...

aussi bête que cela puisse paraitre j arrive pas à le trouver .....

bonjour,

[Steelson]

En principe les revendeurs séreux installent ça selon les préconisation de Microsoft en 32 bits et pas en 64...

Votre version d'Excel n'a probablement rien à voir avec ce que vous indiquez.

Votre version EXCEL est indiquée dans le menu d'aide d'Excel (Fichier > Aide pour les versions 2010 et + ; ou bouton Office pour ceux qui sont en 2007) ...sous la forme suivante :

Cependant pour des raisons mystérieuses on commence à trouver de ci de là quelques version 64 bits dans certains systèmes.

[Diagonale]

Bien vouloir confirmer que vous avez bien cette mention dans votre menu d'aide.

A+

Bonjour,

chez moi c'est 64 bits ...

Il n'y a pas un mot qui est surligné en particulier quand ça bug : juste la ligne ?

Et c'est cette ligne ou tu as le Msg avec PtrSafe ?

? Sinon quel est le Msg Exact ?

En fait je comprend que ça n'a rien à voir avec le 64 bit.

Je suppose que c'est un problème de référence manquante :

Regarde du coté de Outils > Référence et décoche celle qui est déclarée manquante : ça devrait suffire.

Au pire, regarde dans la liste si tu n'as pas une référence identique mais avec un N° de Version plus récent et coche le...

Pour le message avec PtrSafe, je l ai résolu en rajoutant "PtrSafe" après "Déclare"

En recherchant sur internet j'avais trouvé cette information

Du coup je n'avais plus le message

Declare PtrSafe Function GetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Concernant le bug, j ai a nouveau fait un test et là, entre hier et ce matin il n y a plus eu de bug ....!!!

je pense qu'il s'agit d'un problème lié au réseau je vais me débrouiller

merci infiniment de vous en être occupé Steelson et toi même ...

PS : comme je l ai dit à Steelson, je n arrive à localiser le symbole pour indiquer que le problème est résolu