Forums XLPages

Excel & VBA Forum principal [résolu] Récuperation données web

Récuperation données web
#1
jc24
Régulier XLPages

Inscription: 06/09/2010

Messages: 58

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 08-10-2010 19h38

Bonjour Didier, bonjour à tous,

Je sais .......... je suis pénible, mais je cumule les lacunes et la malchance alors que faire si ce n'est en désespoir de cause solliciter à nouveau votre aide.

Didier tu m'avais écrit un petit programme qui me rendait de biens grands services qui me convenait parfaitement (recup données site zeturf), hélas trois fois hélas, le site en question a dû sur injonction d'un autre opérateur cesser de données les cotes PMU. J'ai cherché sur le web, quel site pourrait palier à ce manque qui rend obsolète mon fichier excel. Après avoir trouvé ce site, je m'attèle à essayer de modifier le code pour éviter de revenir à la charge ici et même si j'arrive a me connecter sur ce site après avoir modifier quelques lignes de code, je suis confronté à deux problèmes, le 1er il récupère en plus des données de la date du jour les données de je ne sais combien de jours en arrière, et le 2eme problème c'est qu'il récupère pour toutes les journées que la 3e course, j'ai beau m'acharner dessus rien n'y fait, (ci joint le code modifié). Je vous sollicite donc pour avoir de l'aide pour comprendre le pourquoi du comment.
Grand merci par avance à ceux qui se pencheront sur mon problème
Cordialement

'---------------------------------------------------------------------------------------
' Auteur    : Didier FOURGEOT (myDearFriend!)  -  www.mdf-xlpages.com
' Date      : 14/09/2010
' Sujet     : Récup données Web ZEturf.fr
'---------------------------------------------------------------------------------------
Sub TraitementCotes()
Dim IE As InternetExplorer
Dim IEDoc As HTMLDocument
Dim Col As New Collection
Dim F As Worksheet
Dim T As String
Dim L As Long
Const vURL As String = "http://www.turf-fr.com/cotes-pmu/"
    'Creation nouvelle feuille de stockage
    T = Format(Date, "dd-mm-yyyy")
    On Error Resume Next
    Set F = Sheets(T)
    If F Is Nothing Then
        Set F = Sheets(T & " ®")
    End If
    On Error GoTo 0
    If F Is Nothing Then
        Sheets("Modèle").Copy After:=Sheets(1)
        ActiveSheet.Name = T & " ®"
    Else
        MsgBox "La feuille '" & T & "' existe déjà !" & vbLf & vbLf & "Supprimez l'ancienne feuille (ou renommez-là), puis réessayez...  ", vbOKOnly + vbInformation, "myDearFriend!  -  www.mdf-xlpages.com"
        Exit Sub
    End If
    'TRAITEMENT
    Application.ScreenUpdating = False
    'Crée une instance d'IE invisible
    Set IE = CreateObject("internetExplorer.Application")
    IE.Visible = False
    'Ouvre la page Web
    IE.Navigate vURL
    Do Until IE.readyState = READYSTATE_COMPLETE
        DoEvents
    Loop
    'Récupère la liste de tous les liens intéressants (sans doublon)
    Set IEDoc = IE.Document
    On Error Resume Next
    For L = 0 To IEDoc.Links.Length - 1
        T = IEDoc.Links(L)
        If T Like vURL & "?*" Then
            Col.Add T, T
        End If
    Next L
    On Error GoTo 0
    'MAJ des données
    For L = 1 To Col.Count
        T = Col(L)
        Application.StatusBar = T
        If Len(T) - Len(Replace(T, "/", "")) > 1 Then
            T = Mid(T, Len(vURL) + 1)
            SepareTitre T
            RecupCotes Col(L)
        Else
            T = Mid(T, InStrRev(T, "/") + 1)
            SepareTitre T
        End If
    Next L
    IE.Quit
    'Finition mise en page
    Columns("A:I").EntireColumn.AutoFit
    Range(Cells(4, 3), Cells(DernCell.Row, 9)).HorizontalAlignment = xlRight
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Beep
End Sub

Function DernCell() As Range
    With ActiveSheet
        Set DernCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
    End With
End Function

Sub SepareTitre(T As String)
Dim Plage As Range
    Set Plage = DernCell.Resize(5, 9)
    Plage.ClearContents
    Set Plage = Plage.Resize(1, 9)
    With DernCell.Resize(1, 9)
        With .Interior
            .ColorIndex = 15
            .Pattern = xlSolid
        End With
        .HorizontalAlignment = xlHAlignLeft
        .VerticalAlignment = xlVAlignCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        With .Font
            .Bold = Not InStr(1, T, "/") > 5
            .Name = "Arial Unicode MS"
            .Size = IIf(InStr(1, T, "/"), 9, 12)
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
        End With
        .Range("B1").Value = T
    End With
End Sub

Sub RecupCotes(vURL As String)
Dim R As Range
    Set R = DernCell.Offset(1, 0)
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & vURL, Destination:=R)
        .Name = "LaRequete"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebTables = "10"
        .WebFormatting = xlWebFormattingRTF
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
        .Delete
    End With
    'Efface l'entête
   
End Sub
 

Hors Ligne
 Rapport   Haut 

Re: Récuperation données web
#2
myDearFriend!
Webmestre

Inscription: 18/05/2006
De Saône-et-Loire (71)

Messages: 1539

Système d'exploitation:
PC
Version Excel utilisée:
97, 2000, 2002, 2003, 2007, 2010, 2013, 2016 et 365
Posté le : 09-10-2010 00h48
Bonsoir jc24, le Forum,

Suite de nos précédents travaux donc...
A vrai dire, je pense que je ne vais pas pouvoir me permettre de recommencer tout le travail accompli dans l'ancien fichier... d'autant que ce changement de site va certainement impliquer une révision complète de la façon d'aborder les problèmes...

Pour te venir en aide cependant, tu trouveras ci-joint une proposition qui devrait te permettre de re-partir sur la bonne voie. Dans ce nouveau classeur (que j'aurais préféré que tu joignes), la récupération des cotes pour les 5 premières courses de chaque réunion du jour. Je te laisse voir le reste...

J'ai revu le code de la façon suivante :
'---------------------------------------------------------------------------------------
' Auteur    : Didier FOURGEOT (myDearFriend!)  -  www.mdf-xlpages.com
' Date      : 09/10/2010
' Sujet     : Récup données Web Turf.fr
'---------------------------------------------------------------------------------------
Sub TraitementCotes()
Dim IE As InternetExplorer
Dim IEDoc As HTMLDocument
Dim Col As New Collection
Dim F As Worksheet
Dim T As String, URLrecherche As String
Dim L As Long
Const vURL As String = "http://www.turf-fr.com/cotes-pmu/"
    'Masque d'URL à rechercher
    T = Format(Date, "dddd-d-mmmm-yyyy")
    URLrecherche = vURL & "*_" & T & "*.html"
    'Creation nouvelle feuille de stockage
    On Error Resume Next
    Set F = Sheets(T)
    If F Is Nothing Then
        Set F = Sheets(T & " ®")
    End If
    On Error GoTo 0
    If F Is Nothing Then
        Sheets("Modèle").Copy After:=Sheets(1)
        ActiveSheet.Name = T & " ®"
    Else
        MsgBox "La feuille '" & T & "' existe déjà !" & vbLf & vbLf & "Supprimez l'ancienne feuille (ou renommez-là), puis réessayez...  ", vbOKOnly + vbInformation, "myDearFriend!  -  www.mdf-xlpages.com"
        Exit Sub
    End If
    'TRAITEMENT
    Application.StatusBar = "PATIENTEZ... CONNEXION EN COURS !"
    Application.ScreenUpdating = False
    'Crée une instance d'IE invisible
    Set IE = CreateObject("internetExplorer.Application")
    IE.Visible = False
    'Ouvre la page Web
    IE.Navigate vURL
    Do Until IE.readyState = READYSTATE_COMPLETE
        DoEvents
    Loop
    'Récupère la liste de tous les liens intéressants (sans doublon)
    Set IEDoc = IE.Document
    On Error Resume Next
    For L = 0 To IEDoc.Links.Length - 1
        T = IEDoc.Links(L)
        If T Like URLrecherche Then
            Col.Add T, T
        End If
    Next L
    On Error GoTo 0
    'MAJ des données
    For L = 1 To Col.Count
        T = Col(L)
        Application.StatusBar = T
        If Len(T) - Len(Replace(T, "/", "")) > 1 Then
            T = Mid(T, Len(vURL) + 1)
            SepareTitre T
            RecupCotes Col(L)
        Else
            T = Mid(T, InStrRev(T, "/") + 1)
            SepareTitre T
        End If
    Next L
    IE.Quit
    'Finition mise en page
    Columns("A:I").EntireColumn.AutoFit
    Range(Cells(4, 3), Cells(DernCell.Row, 9)).HorizontalAlignment = xlRight
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Beep
    MsgBox "Traitement terminé !"
End Sub

Function DernCell() As Range
    With ActiveSheet
        Set DernCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
    End With
End Function

Sub SepareTitre(T As String)
Dim Plage As Range
    Set Plage = DernCell.Resize(5, 9)
    Plage.ClearContents
    Set Plage = Plage.Resize(1, 9)
    With DernCell.Resize(1, 9)
        With .Interior
            .ColorIndex = 15
            .Pattern = xlSolid
        End With
        .HorizontalAlignment = xlHAlignLeft
        .VerticalAlignment = xlVAlignCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        With .Font
            .Bold = Not InStr(1, T, "/") > 5
            .Name = "Arial Unicode MS"
            .Size = IIf(InStr(1, T, "/"), 9, 12)
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
        End With
        .Range("B1").Value = T
    End With
End Sub

Sub RecupCotes(vURL As String)
Dim R As Range
    Set R = DernCell.Offset(1, 0)
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & vURL, Destination:=R)
        .Name = "LaRequete"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebTables = "4,7,10,13,16"     '--> liste des tables à récupérer
        .WebFormatting = xlWebFormattingRTF
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
        .Delete
    End With
End Sub

En espérant que ça puisse te dépanner.

Cordialement,
Pièce jointe:
zip mDF_RecupWeb_Turf-fr.zip   [ Taille: 17.83 Ko - Téléchargements: 734 ]
Didier_mDF
Image redimensionnée
Le Webmaster

La réponse vous satisfait ? Merci de revenir solder le sujet en [résolu], voir ce lien
Hors Ligne
 Rapport   Haut 

Re: Récuperation données web
#3
jc24
Régulier XLPages

Inscription: 06/09/2010

Messages: 58

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 10-10-2010 22h31
Bonsoir Didier,

Merci encore une fois d'avoir pris de ton temps pour m'aiguiller sur la résolution de mon problème.

J'ai rencontré une difficulté avec ce que tu m'avais envoyé, car la macro "bloque" sur  Set IEDoc = IE.Document et m'indique Bibliothèque d'objets non gérée alors que la même ligne de code dans les macros pour Zeturf fonctionnait sans problème.

Je me suis qu'a même débrouillé dans ce que j'avais repris sur les macros précédentes que tu m'avais écrit en incrémentant les tables a récupérer de trois en trois, ce qui fait que je récupère l'ensemble des données, par contre la macro récupère l'ensemble des données des jours antérieurs aussi, mais bon c'est pas grave je supprime ce qui m'intéresse pas pour la journée concernée.

Encore une fois tu m'as beaucoup aidé en m'indiquant qu'il fallait incrémenter de 3 en 3 les numeros de tables à récupérer et ca je ne l'aurai certainement pas trouvé tout seul car je ne savais pas que l'on pouvait récupérer X tables sur la même ligne de code.

Je vais mettre à profit tout ce que j'ai appris et découvert grâce à toi pour tenté de récupérer d'autres données sur d'autres sites et cette fois même si j'y arrive pas, promis je t'embêterai plus.

Ah si !!!!!!!!!!!! dès que je suis au point, je ne manquerai pas de t'envoyer le résultat de mes trouvailles au niveau stratégie et de te faire à mon tour bénéficier de mes modestes compétences en matière de turf

Grand merci pour ton aide, ta gentillesse et ta disponibilté

Cordialement
JC
Hors Ligne
 Rapport   Haut 

Re: Récuperation données web
#4
myDearFriend!
Webmestre

Inscription: 18/05/2006
De Saône-et-Loire (71)

Messages: 1539

Système d'exploitation:
PC
Version Excel utilisée:
97, 2000, 2002, 2003, 2007, 2010, 2013, 2016 et 365
Posté le : 10-10-2010 22h51
Bonsoir jc24, le Forum,

Citation :
jc24 a écrit :
J'ai rencontré une difficulté avec ce que tu m'avais envoyé, car la macro "bloque" sur  Set IEDoc = IE.Document et m'indique Bibliothèque d'objets non gérée alors que la même ligne de code dans les macros pour Zeturf fonctionnait sans problème.


Cette erreur est curieuse en effet : vu le message d'erreur, tout porterait à croire qu'il s'agisse d'une référence manquante (via VBA / menu Outils / Références...), mais dans ce cas, tu devrais obtenir ce message bloquant dès les premières lignes de code (instructions Dim ...) et non à cet endroit de la procédure.

Cela dit, j'espère que tu pourras quand même te débrouiller (tu sembles bien parti pour ). Le forum sera bien entendu ravi si tu reviens poster le résultat final de ce projet.

Bien cordialement,
Didier_mDF
Image redimensionnée
Le Webmaster

La réponse vous satisfait ? Merci de revenir solder le sujet en [résolu], voir ce lien
Hors Ligne
 Rapport   Haut 


Vous pouvez voir les sujets.
Vous ne pouvez pas débuter de nouveaux sujets.
Vous ne pouvez pas répondre aux contributions.
Vous ne pouvez pas éditer vos contributions.
Vous ne pouvez pas effacez vos contributions.
Vous ne pouvez pas ajouter de nouveaux sondages.
Vous ne pouvez pas voter en sondage.
Vous ne pouvez pas attacher des fichiers à vos contributions.
Vous ne pouvez pas poster sans approbation.

[Recherche avancée]


Qui consulte actuellement ce sujet ?   1 Utilisateur(s) anonymes