Importation valeur de plusieurs tableaux

Bonjour Steelson,

Peux tu y apporter les modifications avec la première course du jour (aujourd’hui)

Je te le dit tout simplement c’est du Latin pour moi

Merci par avance.

Mets ceci en A1 d l'onglet urls

https://www.geny.com/partants-pmu/2020-01-23-vincennes-pmu-prix-de-la-semaine-internationale_c1123648

Je prends quel fichier ? sur le topic

starwaso a écrit :

Bonjour Steelson,

Peux tu y apporter les modifications avec la première course du jour (aujourd’hui)

Je te le dit tout simplement c’est du Latin pour moi

Merci par avance.

celui-ci par exemple

j'ai eu la même erreur que toi, j'ai ajouté une tempo et allongé les autres

Steelson a écrit :

Jouer avec sendkeys, c'est toujours pointu. En plus il est impossible de travailler en parallèle sur le micro, qui plus est ici de faire des copier/coller.

mon résultat (limité à 5)

J'ai fait deux essais.

Premier lancement je clique sur le bouton magique ça fonctionne mais je n'ai pas les perfs du premier cheval:[

je referme le fichier et je fais un deuxième lancement et ça bug et la petite ligne en rouge est revenue:

Avec le fichier "geny_histo_partants new.xlsm." Ça fonctionne merci beaucoup Steelson

J'ai une petite question. Peut-on limiter l'importation ? Par exemple les dix dernières perfs.

Idem chez moi : premier essai il manquait desperado, et ensuite même bug lié au fait que sendkeys a envoyé dans la macro et non sur le navigateur ...

J'ai allongé les tempos, j'en ai ajouté une avant le sendkeys du code source et c'est ok.

starwaso a écrit :

Avec le fichier "geny_histo_partants new.xlsm." Ça fonctionne merci beaucoup Steelson

J'ai une petite question. Peut-on limiter l'importation ? Par exemple les dix dernières perfs.

Si tu veux, je vais mettre un paramètre, mais cela ne changera rien puisque tout est chargé en n bloc, qu'il y en ait 0, 1, 5 ou 15 ...

Je veux bien pour les dix dernières perfs et aussi de m'expliquer si je veux changer le nombre.

Si je change d’adresse dans l’onglet urls j’ai de nouveau le même bug et la ligne rouge revient

Steelson a écrit :

Je ne suis pas convaincu de l'intérêt / l'efficacité de cette mise en forme, mais je vais l'ajouter tout en préservant la "base de données" qui s'incrémentera à chaque lancement de l'application.

Comment utilises-tu par la suite cette mise en forme ? Qu'est-ce que tu en fais ? (d quoi me motiver)

starwaso a écrit :

Si je change d’adresse dans l’onglet urls j’ai de nouveau le même bug et la ligne rouge revient

J'ai modifié en ajoutant qwant dans les lancements à blanc pour mise en cache ...

Mais sinon, ferme le fichier sans sauvegarder et relance !! je n'ai pas de solutions, c'est pointu. Cela dépend des débits internet et de la rapidité du PC (un PC trop rapide peut être un défaut !!)

starwaso a écrit :

Je veux bien pour les dix dernières perfs et aussi de m'expliquer si je veux changer le nombre.

#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
        (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
        (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Sub telecharger()
Dim nav As Long, MyData As DataObject
Set MyData = New DataObject

' partants
    Range("A1").CurrentRegion.Offset(1, 1).Clear
    txt = HtmlGet([_www])
    tbl = Split(txt, [_split])
    For i = LBound(tbl) + 1 To UBound(tbl)
        Range("B" & i + 1) = "https://www.geny.com" & Split(Split(tbl(i), [_pre])(1), [_post])(0)
    Next

' pour mise en cache du navigateur
    nav = ShellExecute(0, "open", "https://www.qwant.com/", 0, 0, 1)
    With Sheets("urls")
        For i = 2 To .Range("B" & Rows.Count).End(xlUp).Row
            nav = ShellExecute(0, "open", .Range("B" & i), 0, 0, 1)
        Next
    End With
    Application.Wait (Now + TimeValue("00:00:12"))
    SendKeys "%{F4}"

' suppression des feuilles éventuelles
    Application.DisplayAlerts = False
    For Each sh In Worksheets
        If sh.Name Like "c*" Then sh.Delete
    Next
    Application.DisplayAlerts = True

' interrogation des sources et collecte des informations
    With Sheets("urls")
        Set sh = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
        sh.Name = Split([_www], "_")(1)
        For i = 2 To .Range("B" & Rows.Count).End(xlUp).Row
            Range("A" & 20 * (i - 2) + 1) = i - 1
            Range("A" & 20 * (i - 2) + 2) = Split(Split(.Range("B" & i), "/")(UBound(Split(.Range("B" & i), "/"))), "_")(0)
            Range("B" & 20 * (i - 2) + 2).Select
            Application.Wait (Now + TimeValue("00:00:01"))
            nav = ShellExecute(0, "open", "https://www.qwant.com/", 0, 0, 1)
            Application.Wait (Now + TimeValue("00:00:03"))
            SendKeys "%d"
            Application.Wait (Now + TimeValue("00:00:03"))
            SendKeys "view-source:" & .Range("B" & i)
            SendKeys "{ENTER}"
            Application.Wait (Now + TimeValue("00:00:04"))
            SendKeys "^a"
            Application.Wait (Now + TimeValue("00:00:02"))
            SendKeys "^c"
            Application.Wait (Now + TimeValue("00:00:02"))
            MyData.GetFromClipboard
            txt = MyData.GetText(1)
            If InStr(txt, [_avant]) <> 0 Then
                txt = [_avant] & Split(Split(txt, [_avant])(1), [_apres])(0) & [_apres]
                SendKeys "%{F4}"
                MyData.SetText Text:=Empty
                MyData.PutInClipboard
                MyData.SetText txt
                MyData.PutInClipboard
                Application.Wait (Now + TimeValue("00:00:02"))
                ActiveSheet.Paste
                der = Application.Max(Range("B" & Rows.Count).End(xlUp).Row, 20 * (i - 2) + 4 + [_nb])
                Rows(20 * (i - 2) + 3 + [_nb] & ":" & der).Delete Shift:=xlUp
            End If
        Next
    End With
    Sheets("modèle").Cells.Copy
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

    MsgBox "Terminé !"
End Sub

Pour changer le nombre ... onglet paramètres

Merci, j'ai testé pas de bug mais j'ai les mêmes perfs pour les deux premiers chevaux

Testé avec cette adresse :

c 'est la troisième course d'aujourd'hui.

starwaso a écrit :

Merci, j'ai testé pas de bug mais j'ai les mêmes perfs pour les deux premiers chevaux

Là je pense que tu trompes ou tu n'as pas bien compris mon message, regarde le dernier fichier que je t'ai envoyé en dernier