Autres Multichrono à problèmes

a26

XLDnaute Occasionnel
Bonjour à tous,
Quelqu'un peut-il m'aider à résoudre le problème suivant. Un fichier multichrono parfait sauf que les chronos s'arrêtent dès qu'il y a une saisie dans une cellule de la page. Ayant besoin de faire des saisies sur cette même feuille je ne vois pas comment modifier la macro.
Merci pour votre aide.
Cordialement,
a26
 

Pièces jointes

  • multichrono.xlsm
    31.2 KB · Affichages: 10

Dranreb

XLDnaute Barbatruc
Bonjour.
On ne peut pas éviter qu'Excel s'accapare la main pendant l'édition d'une cellule, empêchant la mise à jour de l'affichage d'un chronomètre.
Mais ça n'arrête pas le temps quand même ! Alors je ne vois pas bien où est le problème.
Il n'y en a pas dans le classeur joint en tout cas.
 

Pièces jointes

  • Progression.xlsm
    289.6 KB · Affichages: 22
Dernière édition:

Dranreb

XLDnaute Barbatruc
Il faut procéder autrement je pense.
Ce n'est pas normal d'empêcher la Sub Worksheet_BeforeDoubleClick de se terminer en lui imposant l'appel d'une procédure qui ne se termine pas. Essayez une procédure qui se rappelle elle meme toutes les secondes par un Appilcation.OnTime, ou utilisez un dispositif de mon classeur qui fonctionne.
 

a26

XLDnaute Occasionnel
Voilà ce que j'ai quand j'ouvre ton fichier en PJ.
Je ne suis pas assez calé en VBA pour m'en sortir.
Cordialement,
a26
1032020
 

Dranreb

XLDnaute Barbatruc
Remplacez dans tout le projet tous les PtrSafe par rien.
Dans la mesure où le défilement du temps, qui ne sert à rien de toute façon, peut être interrompu par des manœuvre dans Excel, à votre place je noterais plutôt dans la colonne D l'heure d'arrivée, et dans le module de la feuille:
VB:
Option Explicit
            #If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
            #Else
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
               #End If
Private CycMinuit As Currency, Fréq As Currency
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Heure As Double
   Heure = HeurePrécise
   If Target.Column <> 2 Or Target.CountLarge <> 1 Then Exit Sub
   Select Case Target.Value
      Case "Go":   Target.Offset(, 1).Value = Heure
         Target.Offset(, 2).Value = Empty: Target.Offset(, 3).Value = Empty: Target.Value = "Stop"
      Case "Stop": Target.Offset(, 2).Value = Heure
         Target.Offset(, 3).FormulaR1C1 = "=RC4-RC3": Target.Value = "Go"
      End Select
   Target.Offset(, 1).Resize(, 3).NumberFormat = "hh:mm:ss.000"
   End Sub
Function HeurePrécise() As Double
   Dim Cyc As Currency, CycTrv As Currency
   QueryPerformanceCounter Cyc
   If CycMinuit = 0 Or Fréq = 0 Then
      Dim Ti As Single, Ts As Single
      QueryPerformanceFrequency Fréq
      Ti = Timer: Do: Ts = Timer: Loop Until Ts <> Ti
      QueryPerformanceCounter CycTrv
      CycMinuit = CycTrv - Ts * Fréq
      End If
   HeurePrécise = (Cyc - CycMinuit) / (Fréq * 86400)
   End Function
 

Dranreb

XLDnaute Barbatruc
Au cas où ça devait pouvoir fonctionner durant le passage à l'heure de minuit, j'insèrerais la date en colonne C.
Il ne faut pas l'intégrer, même non affichée par le format de cellule, à l'heure: celle ci perdrait en précision.
La programmation devient alors celle ci :
VB:
Option Explicit
            #If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
            #Else
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
               #End If
Private CycMinuit As Currency, Fréq As Currency
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Heure As Double
   Heure = HeurePrécise
   If Target.Column <> 2 Or Target.CountLarge <> 1 Then Exit Sub
   Select Case Target.Value
      Case "Go":   Target.Offset(, 1) = Date: Target.Offset(, 2).Value = Heure
         Target.Offset(, 3).Value = Empty: Target.Offset(, 4).Value = Empty
         Target.Value = "Stop": Target.Offset(, 1).Resize(, 2).Select
      Case "Stop": Target.Offset(, 3).Value = Heure + (Date - Target.Offset(, 1))
         Target.Offset(, 4).FormulaR1C1 = "=RC[-1]-RC[-2]"
         Target.Value = "Go": Target.Offset(, 3).Resize(, 2).Select
      End Select
   Target.Offset(, 1).NumberFormat = "ddd dd mmm"
   Target.Offset(, 2).Resize(, 3).NumberFormat = "[h]:mm:ss.000"
   End Sub
Function HeurePrécise() As Double
   Dim Cyc As Currency, Ti As Single, Ts As Single, CycTrv As Currency
   QueryPerformanceCounter Cyc
   If CycMinuit = 0 Or Fréq = 0 Then
      QueryPerformanceFrequency Fréq
      Ti = Timer: Do: Ts = Timer: Loop Until Ts <> Ti
      QueryPerformanceCounter CycTrv
      CycMinuit = CycTrv - Ts * Fréq
      End If
   HeurePrécise = (Cyc - CycMinuit) / (Fréq * 86400)
   End Function
 

Dranreb

XLDnaute Barbatruc
D'ailleurs je ne sais mème pas ce que vous voulez essayer: Est-ce d'implanter un UFmChrono dans votre classeur ou d'essayer la procédure proposée au poste #11 ?
Attention: l'UFmChrono a besoin du module de classe Rythmeur, qui lui même utilise le module de service MRythmeur. Il faut donc glisser/déplacer non seulemnt l'UFmChrono vers votre projet, mais aussi ces deux choses.
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 730
Messages
2 081 981
Membres
101 855
dernier inscrit
alexis345