Importer des données d'un site Web

Le 17/08/2015 à 11:07

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

Le 19/03/2016 à 20:14

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

Rechercher des sujets similaires à "importer donnees site web"