Titre du sujet : Re: Récupération de données turfiques du site gény course
par myDearFriend! le 17/10/2011 00:25:57
Bonsoir chakir123, le Forum,
Bon, je ne t'avais pas oublié, j'ai malheureusement très peu de temps disponible depuis quelques temps...
Tu trouveras en pièce jointe un tentative de réponse à ton besoin, qui j'espère pourra te satisfaire car, bien occupé par ailleurs, je ne peux me permettre d'investir plus de temps sur ta demande.
Pour information, j'ai utilisé le code VBA suivant :
Option Explicit
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 16/10/2011
' Sujet : Récup données Web : Geny.com
'---------------------------------------------------------------------------------------
Sub ListeCourses()
Dim IE As InternetExplorer
Dim IEdoc As HTMLDocument
Dim O As Object
Dim vUrl As String, T As String
'Prépare la feuille
ActiveSheet.Range("15:100").Delete
Application.ScreenUpdating = False
'URL de départ
vUrl = "http://www.geny.com/reunions-courses-pmu"
'Ouvre la page web dans IE de façon invisible
Set IE = CreateObject("internetExplorer.Application")
IE.Visible = False
'Ouvrir la page Web
IE.Navigate vUrl
Do Until IE.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
Set IEdoc = IE.Document
vUrl = "http://www.geny.com/partants-pmu/"
'Mémoriser les liens utiles
With ActiveSheet.ComboBox1
.Clear
.ColumnCount = 2
.BoundColumn = 2
.Style = fmStyleDropDownList
.AddItem "< choisir une course >"
For Each O In IEdoc.Links
If O.href Like vUrl & "*" Then
T = Mid(O.href, Len(vUrl) + 1)
T = Left(T, InStrRev(T, "_") - 1)
.AddItem T
.List(.ListCount - 1, 1) = O.href
End If
Next O
.ListIndex = 0
End With
'Quitter IE
Set IEdoc = Nothing
IE.Quit
Set IE = Nothing
Application.ScreenUpdating = True
MsgBox "Liste mise à jour avec succès !" & vbLf & vbLf & "- Choisissez une course dans la liste," & vbLf & "- Cliquez ensuite sur « Stats Partants » " & vbLf & "- Puis, patientez ... ", vbInformation + vbOKOnly, "myDearFriend! - www.mdf-xlpages.com"
End Sub
Sub RecupPartants()
Dim Plage As Range
Dim TabTemp As Variant
Dim vUrl As String
Dim DernLign As Long, L As Long
Dim DernCol As Integer
Application.ScreenUpdating = False
With ActiveSheet
'Récupère tableau des partants
.Range("15:100").Delete
With .ComboBox1
If .ListIndex < 1 Then Exit Sub
vUrl = .Value
End With
With .QueryTables.Add(Connection:="URL;" & vUrl, Destination:=.Range("B15"))
.Name = "mDFquery"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "tableau_partants"
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = False
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
'Récupére la carrière de chaque cheval
DernCol = .Cells(16, .Columns.Count).End(xlToLeft).Column
DernLign = .Cells(.Rows.Count, 2).End(xlUp).Row
Set Plage = .Range(.Cells(17, 2), .Cells(DernLign, DernCol + 3))
TabTemp = Plage.Value
For L = 1 To UBound(TabTemp)
vUrl = Plage.Cells(L, 2).Hyperlinks(1).Address
RecupCarriere vUrl, DernLign + 1
TabTemp(L, DernCol) = .Cells(DernLign + 2, 3)
TabTemp(L, DernCol + 1) = .Cells(DernLign + 2, 4)
TabTemp(L, DernCol + 2) = .Cells(DernLign + 2, 5)
Next L
Plage.Value = TabTemp
'Mise en forme
.Range(.Cells(DernLign + 1, 3), .Cells(DernLign + 1, 5)).Copy Destination:=.Cells(Plage(1).Row - 1, DernCol + 1)
.Range(DernLign + 1 & ":1000").Delete
.Columns(DernCol).Copy
.Range(.Cells(1, DernCol + 1), .Cells(1, DernCol + 3)).EntireColumn.PasteSpecial Paste:=xlPasteFormats
.Cells.Hyperlinks.Delete
With Plage.Borders()
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.Cells.EntireColumn.AutoFit
.Cells(15, 2).Select
End With
Application.ScreenUpdating = True
Beep
End Sub
Sub RecupCarriere(vUrl As String, Lign As Long)
With ActiveSheet
.Range(Lign & ":1000").Delete
With .QueryTables.Add(Connection:="URL;" & vUrl, Destination:=.Cells(Lign, 2))
.Name = "mDFquery"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingRTF
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = False
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End With
End Sub
Cordialement,
|
Didier FOURGEOT