Rapport de message :*
 

Regrouper les données Zeturf

Titre du sujet : Regrouper les données Zeturf
par jc24 le 28/09/2010 13:26:52

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