Actualiser une macro toute les 15 mn

[claude09]

Bonjour.Une macro me récupère les cotes de chevaux d'une course PMU.Quand je lance la macro(affichage,afficher les macros),les cotes se mettent en colonneC.Comment faire pour actualiser automatiquement toutes les 15mn a partir de l'ouverture de la macro et que les cotes se mettent en colonne D,E F etc.Et comment arrêter définitivement la macro quand je le désire?
Merci pour vos réponses.
Ci joint le fichier.

 

[Dranreb]

Bonjour.
Ajoutez ça en tête du module :

Option Explicit
Private Heure As Double
Sub PlanifTurf()
DéplanifTurf
Heure = Now + TimeSerial(0, 15, 0)
Application.OnTime Heure, "Turf"
End Sub
Sub DéplanifTurf()
If Heure = 0 Then Exit Sub
Application.OnTime Heure, "Turf", Schedule:=False
Heure = 0
End Sub

Mettez PlanifiTurf là où vous voulez le lancer, y compris à la fin de la Sub Turf pour reconduire, et DéplanifTurf pour arrêter, y compris dans une Workbook_BeforeClose du module ThisWorkbook. À tester.

 

[claude09]

Merci bien mais je nage complètement!!
Je vous met le code pour modifications;merci
Option Explicit
Private Heure As Double
Sub PlanifTurf()
DéplanifTurf
Heure = Now + TimeSerial(0, 15, 0)
Application.OnTime Heure, "Turf"
End Sub
Sub DéplanifTurf()
If Heure = 0 Then Exit Sub
Application.OnTime Heure, "Turf", Schedule:=False
Heure = 0
End Sub
Sub Turf()
Dim ScriptControl As Object, PMU As Object
Dim Ecurie As Object, Cheval As Object, Drd As Object, Gp As Object
Dim Site As String, i As Long

Set ScriptControl = CreateObject("MSScriptControl.ScriptControl")
ScriptControl.Language = "JScript"

Site = "https://offline.turfinfo.api.pmu.fr/rest/client/7/programme/17112018/R1/C7/participants"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", Site, False
.send
Set PMU = ScriptControl.Eval("(" + .responseText + ")")
.abort
End With

i = 2
Set Ecurie = PMU.participants
On Error Resume Next
For Each Cheval In Ecurie
With ActiveSheet
.Cells(i, 1).Value = Cheval.numPmu
.Cells(i, 2).Value = Cheval.nom
Set Drd = Cheval.dernierRapportDirect
.Cells(i, 3).Value = Drd.rapport

i = i + 1
End With

Next Cheval

Set Drd = Nothing
Set Gp = Nothing
Set Ecurie = Nothing
Set PMU = Nothing
Set ScriptControl = Nothing
Sub PlanifTurf()
DéplanifTurf
Heure = Now + TimeSerial(0, 15, 0)
Application.OnTime Heure, "Turf"
End Sub



End Sub

 

[Dranreb]

Supprimez vos 4 instructions avant la End Sub et mettez simplement à la place PlanifTurf ou bien Call PlanifTurf

 

[claude09]

Cad,supprimer set Drd,Set ecurie,set pmuetset scripControl?je précise que je suis nul en vba!!!

 

[Dranreb]

Non, je n'ai jamais dit de changer quoi que ce soit d'autre.
Bon, finalement n'ajoutez rien dans la Sub Turf, laissez la comme à l'origine.
Mais remplacez tout ce qui précède par :

Option Explicit
Private Heure As Double
Sub PlanifTurf()
   DéplanifTurf
   Heure = Int(Now * 96 + 1.5) / 96
   Application.OnTime Heure, "TurfQuartDHeure"
   End Sub
Sub DéplanifTurf()
   If Heure = 0 Then Exit Sub
   Application.OnTime Heure, "TurfQuartDHeure", Schedule:=False
   Heure = 0
   End Sub
Private Sub TurfQuartDHeure()
   Heure = 0: Turf: PlanifTurf
   End Sub

Si vous voulez, via un bouton par exemple, exécuter Turf de telle sorte qu'il s'exécute ensuite à nouveau tous les quart d'heures justes, faites lui exécuter plutôt à la place TurfQuartDHeure

 

[claude09]

je cale pour attribuer cette macro a un bouton!!

 

[claude09]

Excel ne trouve pas cette macro.

 

[claude09]

je pense avoir trouvé,j'ai inséré turfquartdheure dans un nouveau module et j'ai pu affecter un bouton à cette macro.Ensuite,j'ai trouvé un code qui décale d'une colonne les cotes a chaque actualisation.Je vais voir dans 1/4 d'heure si l'actualisation se fait correctement.

 

[claude09]

je pense que çà fonctionne,si je veux mettre 10 mn au lieu de 15,c'est ici qu'il faut modifier:Heure = Int(Now * 96 + 1.5) / 96,en remplaçant 1.5 par 1.0?

 

[Dranreb]

Alors, ce serait Int(Now * 144 + 1.5) / 144, je pense, mais si tous les quarts d'heure entiers ça se comprend, toutes les dix minutes entières ce n'est guère courant. Il vaut peut être mieux revenir à Now + TimeSerial(0, 10, 0)

 

[claude09]

merci,je verrai çà demain,je sature!!Bonne soirée