Titre du sujet : Re: import page web
par myDearFriend! le 24/05/2010 23:20:35
Bonsoir gmh, le Forum,
Contrairement à l'exemple fourni précédemment, tu souhaites finalement récupérer l'ensemble des données de la page Web et non plus seulement les données d'entête  (et si tu nous disais tout la prochaine fois, ça ne serait pas plus simple ?)
Dans la nouvelle pièce jointe, j'ai donc repris la totalité de la procédure VBA et repars donc avec le code suivant :
Option Explicit
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 24/05/2010
' Sujet : Récup données Web PMU
'---------------------------------------------------------------------------------------
Sub Traitement()
Dim vURL As String
Dim D As String, NumCourse As String
With Sheets("Accueil")
D = .Range("E2").Text
NumCourse = .Range("E4").Text
End With
'URL de départ
vURL = "http://www.pmu.fr/pmu/servlet/pmu.web ... etaillesServlet?dd=" _
& D & "&idc=" & NumCourse & "&np=1&ppd=0"
'Traiter
RecupChevaux vURL
End Sub
Sub RecupChevaux(ByVal vURL As String)
Dim IE As InternetExplorer
Dim O As Object, OI As Object, OIS As Object
Dim L As Long
'Ouvre la page web dans IE de façon invisible
Set IE = CreateObject("internetExplorer.Application")
IE.Visible = False
'RAZ de la feuille
ActiveSheet.Cells.Delete
Application.ScreenUpdating = False
On Error Resume Next
'Boucle sur l'ensemble des partants
Do
If vURL = "" Then
'Bouton "Suivant" sur la page Web ?
For Each OI In IE.Document.Links
If OI.Title = "Suivant" Then
vURL = OI.href
End If
Next OI
End If
If vURL = "" Then Exit Do 'Sortir à la fin
'Ouvrir la page Web
IE.Navigate vURL
Do Until IE.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
'Détermine première ligne libre
L = Cells(Rows.Count, 1).End(xlUp).Row + 3
'Récup Nom du partant
Set O = IE.Document.getElementsByTagName("H1")
For Each OI In O
L = L + 1
With Cells(L, 1)
.Value = OI.innerText
.Font.Bold = True
Application.StatusBar = .Value
End With
Next OI
'Récup Détail du partant
Set O = IE.Document.getElementsByTagName("P")
For Each OI In O
If OI.innerText <> " Retour à l'accueil de pmu.fr" Then
Set OIS = OI.getElementsByTagName("span")
L = L + 1
With Cells(L, 1)
.Value = OIS.Item(0).innerText
End With
With Cells(L, 2)
.Value = OIS.Item(1).innerText
End With
End If
Next OI
RecupPlusDetails Cells(L + 2, 1), vURL
vURL = ""
If L > 150 Then Exit Do
Loop
Columns(1).AutoFit
ActiveSheet.UsedRange.HorizontalAlignment = xlLeft
Application.ScreenUpdating = True
'Fermer IE
IE.Quit
Application.StatusBar = False
MsgBox "Traitement terminé ! ", vbInformation + vbOKOnly, "myDearFriend! - www.mdf-xlpages.com"
End Sub
Sub RecupPlusDetails(R As Range, vURL As String)
With ActiveSheet.QueryTables.Add(Connection:="URL;" & vURL, Destination:=R)
.Name = "LaRequete"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "1"
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
End Sub
Par ailleurs, pour des raisons évidentes de test, j'ai dû supprimer la formule que tu avais mis en cellule E2 de ta feuille "Accueil".
En espérant que ça te convienne.
Cordialement,
|
Didier FOURGEOT