Importer des données d'un site Web
Bonjour,
Ayant aucune connaissance en langage informatique, je voudrais importer des données du tableau des partant à une course pmu : http://www.geny.com/partants-pmu/2015-08-17-chateaubriant-pmu-grand-prix-de-chateaubriant_c740667.
J'ai récupéré un vieux fichier avec des données mais ça ne marche pas :
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 SUR MON FICHIER c'est colorié en jaune, je suppose que c'est l'erreur ?
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
Merci d'avance
bonsoir je ne c'est pas si tu a trouver une reponse a ton PB mais j'ai le meme soucis par contre j'ai un peu plus avancer moi je voudrai certaine info du site geny !! mais je bloque
je te joint le code que j'ai deja qui fonctionne pour passer le site car il est proteger enfaite et voir si toi tu arrive a recuperer les info journaliere via ce code car moi j'ai celle de la date demander mais j'arrive pas enfaite a changer la date meme en creeant un bouton d'actualisation
merci a toi on peu aussi peu etre changer certaine methode pmu voir ou surtout deja voir l'avancement sur ce probleme
donc voici le code
Sub test()
Columns("A:l").Clear
Dim ReQ As Object, UrL As String
UrL = "http://www.geny.com/partants-pmu/2015-05-19-longchamp-pmu-prix-des-gobelins_c714591"
Set ReQ = CreateObject("microsoft.xmlhttp")
ReQ.Open "POST", UrL, False
ReQ.setRequestHeader "Accept", "text/html, application/xhtml+xml, */*"
ReQ.setRequestHeader "Accept-Language", "fr-FR"
ReQ.setRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"
ReQ.setRequestHeader "Accept-Encoding", "gzip, deflate"
ReQ.setRequestHeader "Host", "www.geny.com"
ReQ.setRequestHeader "DNT", 1
ReQ.setRequestHeader "Connection", "Keep - Alive"
ReQ.setRequestHeader "Cookie", " JSESSIONID=3E554B80B1ABBC36A2C53EC91C219C77.raoul_1;"
ReQ.send
'MsgBox ReQ.responsetext
Set fauxdoc = CreateObject("htmlfile")
With fauxdoc
.body.innerhtml = ReQ.responsetext
Set grouptable = .getelementsbytagname("TABLE")
For i = 0 To grouptable.Length - 1
If grouptable(i).ParentNode.ID = "dt_partants" Then Set matable = grouptable(i)
Next
For Each elem In matable.all
If elem.tagname = "TD" Then elem.innerhtml = elem.innertext
Next
faire = .ParentWindow.clipboardData.SetData("text", matable.outerhtml)
With Sheets(1)
Set cel = .Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
cel.Select
.Paste:
End With
faire = .ParentWindow.clipboardData.ClearData("text")
End With
End Sub
Cordialement
merci de ta reponse