Discussion :

[knagni]

Bonjour,
Je suis encore débutant en VBA
Je travaille depuis un certain temps à automatiser l'importation de plusieurs pages web sur Excel. mais je me heurte à des difficultés.
La procédure fonctionne mais il arrive souvent qu'il apparaisse l'erreur "Délai de connexion dépassé". Comment faire pour y remédier?
Par ailleurs je souhaiterais importer les codes sources des pages web sur Excel, à partir de quoi je pourrais accéder aux données des liens sélectionnés.
Et Enfin, je trouve l'exécution de la procédure un peu lente (environ 15 mn pour environ 6000 lignes traitées).
Pourriez vous m'aider à trouver des solutions?
ci - dessous la procédure d'importation que j'utilise.
Merci d'avance.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub req_web_Chev(Chaine As String)
 
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
 
On Error GoTo Erreurs1
 
 
 With Workbooks("Etat Préparatoire Courses").Worksheets("Perf Chev")
 With .QueryTables.Add(Connection:= _
 "URL;" & Chaine, _
 Destination:=.Range("B1048576").End(xlUp).Offset(1, 0))
 
 .BackgroundQuery = True
 .TablesOnlyFromHTML = True
 .Refresh BackgroundQuery:=False
 .SaveData = True
 End With
 End With
 
Exit Sub
 
Erreurs1:
 
Workbooks("Etat Préparatoire Courses").Worksheets("Perf Chev").UsedRange.ClearContents
Call Importations_Chev
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

[patricktoulon]

re
bonjour est ilpossible d'avoir cette url ???

[knagni]

Exemple d'Url

Liste URL.xlsx

Merci.

[patricktoulon]

re
d'accords encore un nouveau sebphito
si tu fait une recherche avec ce pseudo tu trouvera plein de chose sur geny et autre site de turf

cela dit 6000 requetes il faut pas t'etonner du temps d'execution surtout avec querytable d'excel
perso je prefere le faire moi meme en vba la requete
je te fait un exemple donne moi 5 minutes juste pour verifier si la structure des page genycourse est toujour obstensible par requetes

apres plutot que de recupérer tout le code source on peut récupérer juste ce dont tu a besoins

aussi si tu te donne la peine de chercher marcl propose un exemple de multithread (requetes) dans les contributions

en bref tu a ce que tu cherche 300 fois dans le forum
je reviens ....+

[patricktoulon]

re
bon voila un 1er jet de l'idée de base
regarde ce que je recupere dans le sheets resultat que j'ai ajouté

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Sub testrequete()
    With Sheets("resultat"): .Activate: .Cells.Clear: End With
    For i = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        requete Sheets(1).Cells(i, 1).Value
    Next
    deleteshap
    MsgBox "terminé!!"
End Sub
Sub requete(url)
    Dim req
    Set req = CreateObject("microsoft.xmlhttp")
    req.Open "POST", url, False
    req.send
    With CreateObject("htmlfile")
        .body.innerhtml = req.responsetext
        Set tables = .getelementsbytagname("TABLE")
        texte = "<style>TD{border:1px solid black;}</style>" & vbCrLf & "<font color=red><strong>" & .getelementsbytagname("H1")(0).innertext & "</strong><br> musique :" & .getelementsbytagname("H3")(0).innertext & "</font>" & tables(1).outerhtml & tables(3).outerhtml
        If .parentWindow.clipboardData.setData("Text", texte) Then
            Application.ScreenUpdating = False
            With Sheets("resultat")
                .Cells(Rows.Count, 1).End(xlUp).Offset(3, 0).Select
                .Paste
            .Columns("A:z").AutoFit
            End With
            .parentWindow.clipboardData.clearData "Text"
        End If
    End With
End Sub
Sub deleteshap()
    For Each shap In Sheets(2).Shapes
        shap.Delete
    Next
End Sub

regarde le gif jusqu'au bout


teste ce fichier

[patricktoulon]

re
si tu veux le lien de la course du jour (quinté)voici
une petite sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub test_recuplinkquinteToday()
    Dim req
    Set req = CreateObject("microsoft.xmlhttp")
    req.Open "POST", "http://www.geny.com/reunions-courses-pmu?" & Format(Date, "yyyy-mm-dd"), False
    req.send
    Debug.Print
    With CreateObject("htmlfile")
        .body.innerhtml = req.responsetext
        For Each elem In .getelementsbytagname("a")
            If elem.href Like "*centpourcent-quinte*" Then Debug.Print Replace(elem.href, "about", "http://www.geny.com")
        Next
    End With
End Sub

parti de ce lien tu peux recupérer les liens des chevaux dans le tableau a droite

tag ton post resolu si tu a ce qu'il te faut comme ca j'arrete le suivi