Forums XLPages

Excel & VBA Forum principal [résolu] Regrouper les données Zeturf

Regrouper les données Zeturf
#1
jc24
Régulier XLPages

Inscription: 06/09/2010

Messages: 58

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 28-09-2010 13h26
Bonjour Didier, bonjour à tous,

J'ai mis mon silence à profit pour potasser et j'espère progresser dans la programmation VBA, je suis pas trop mécontent e moi puisque grâce à toi, Didier, j'ai réussi en prenant exemple sur ton code a récupérer d'autres données sur le site Zeturf, mais j'arrive pas à faire figurer toutes les données sur la même page, en effet je récupére les cotes et les rapports sur un fichier (celui que tu m'as créé, que j'appelle fichier 1) et je récupére les autres données sur un autre fichier, le problème se situe dans la mise en forme de ce dernier fichier puisque si il me récupére bien les données voulues  la mise en page ne correspond pas a celle du 1er fichier (voir PJ1). L'idéal serait qu'un même fichier récupère les 3 données (côtes, rapports et pronostic). Je joins le code du 2e fichier.
Sub TraitementProno()
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.zeturf.fr/fr/programme/"
    '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, "/", "")) > 5 Then
            T = Mid(T, Len(vURL) + 1)
            SepareTitre T
            RecupProno 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(1, 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(1, 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, "/") > 0
            .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 RecupProno(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 = "5"
        .WebFormatting = xlWebFormattingRTF
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
        .Delete
    End With
   
End Sub
 
J'ai beau bidouillé je n'arrive pas à faire correspondre les données en copiant les données du fichier 2 sur le fichier 1

Merci de votre aide
Cordialement
Pièce jointe:
zip Classeur1.zip   [ Taille: 12.43 Ko - Téléchargements: 601 ]
Hors Ligne
 Rapport   Haut 

Re: Regrouper les données Zeturf
#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 : 28-09-2010 22h05
Bonsoir jc24,

Tu trouveras en pièce jointe mon interprétation de ta demande...

En reprenant pour base le fichier réalisé pour ton fil précédent :
Cette fois, le bouton vert permet de récupérer à la fois les Rapports et les Pronos en amont.

Cela dit, j'avoue que j'ai un peu de mal à comprendre ta façon d'aborder la chronologie des évènements... Vouloir récupérer les pronos à postériori (après résultats des courses !), c'est une logique qui m'échappe.

Pour info, j'ai modifié le module de code "ModRapports" comme suit afin d'imbriqué les 2 traitements :

Option Explicit
'---------------------------------------------------------------------------------------
' Auteur    : Didier FOURGEOT (myDearFriend!)  -  www.mdf-xlpages.com
' Date      : 28/09/2010
' Sujet     : Récup données Web ZEturf.fr
'---------------------------------------------------------------------------------------
Sub TraitementRapportsEtPronos()
Dim F As Worksheet
Dim Plage As Range, R As Range
Dim Lien As String, D As String
Const vURL As String = "http://www.zeturf.fr/fr/resultats/"
Const vURL2 As String = "http://www.zeturf.fr/fr/programme/"

    For Each F In Worksheets
        With F
           If Right(F.Name, 2) = " ®" Then
                'Si onglet <> aujourd'hui
                D = Replace(.Name, " ®", "")
                If DateValue(D) <> Date Then
                    'Préparer la feuille cible
                     .Activate
                    .Columns("K:IV").Delete Shift:=xlToLeft
                    Application.ScreenUpdating = False
                    'Récup des données web
                    Set Plage = .Range(.Cells(4, 1), DernCell.Offset(-1, 0)).SpecialCells(xlCellTypeBlanks)
                    For Each R In Plage
                        Lien = R.Offset(0, 1).Text
                        If InStr(1, Lien, "/") > 0 Then
                            Application.StatusBar = Lien
                            RecupRapports vURL & Lien, R.Offset(-2, 10)
                            RecupPronos vURL2 & Lien, R.Offset(1, 20)
                        End If
                    Next R
                    'mise en forme
                    .Range("K:N,Q:Q,S:S").Delete Shift:=xlToLeft
                    .Columns("K:P").EntireColumn.AutoFit
                    .Range("A1").Select
                    'Renommer l'onglet (supprimer le tag '®')
                    .Name = D
                    Application.ScreenUpdating = True
               End If
           End If
        End With
    Next F
    Application.StatusBar = False
    Beep
End Sub

Sub RecupRapports(vURL As String, R As Range)
    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"
        .WebFormatting = xlWebFormattingRTF
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
        .Delete
    End With
    'Efface l'entête
    R.Resize(3, 9).ClearContents
End Sub

Sub RecupPronos(vURL As String, R As Range)
    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 = "5"
        .WebFormatting = xlWebFormattingRTF
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
        .Delete
    End With
End Sub

J'espère que ça pourra te convenir.

Cordialement,


Nb: à l'attention des visiteurs intéressés : le classeur en pièce jointe exploite des requêtes web via le navigateur Internet Explorer. Ceci explique notamment pourquoi il ne fonctionne pas sous environnement Mac.

Pièce jointe:
zip mDF_RecupWebZEturf v3.zip   [ Taille: 79.66 Ko - Téléchargements: 804 ]
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: Regrouper les données Zeturf
#3
jc24
Régulier XLPages

Inscription: 06/09/2010

Messages: 58

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 29-09-2010 10h06
Bonjour Didier,

Encore une fois mille merci pour ton aide et ta disponibilité, une fois de plus les nouvelles macros correspondent exactement à ce que je voulais.
Concernant la chronologie des éléments, peut importe que je récupère les infos une fois l'arrivée connue, ces fichiers me servent à me constituer une solide base de données. Comme je travaille je ne peux récupérer les infos que le soir. Mais quand je serais prêt à me lancer, ce problème ne se posera pas puisque j'aurai la possibilité de voir en direct les infos dont j'ai besoin sur le site et je pourrai ainsi appliquer ma stratégie sur la base des infos que j'aurais collecté ultérieurement.
De plus je pense avoir trouvé une parade (je vais programmer ca ce soir) pour tout récupérer le jour même (côtes, arrivées, rapports et pronos).
Si mes modestes capacités en VBA me permettent de résoudre ce problème de posteriori je ne manquerai pas d'indiquer sur le forum la nouvelle macro, afin que tous ceux qui sont intéressés puissent en profiter.

Grand merci pour ton aide et grâce à toi, j'ai plus progressé en VBA en 3 semaines qu'en 2 ans, tant les macros que tu as réalisées sont didactiques et facilement compréhensibles

Cordialement
JC


(et je n'oublie pas tes 5% lol)
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