Titre du sujet : Récuperation données web
par jc24 le 08/10/2010 19:38:09
Bonjour Didier, bonjour à tous,
Je sais .......... je suis pénible, mais je cumule les lacunes et la malchance alors que faire si ce n'est en désespoir de cause solliciter à nouveau votre aide.
Didier tu m'avais écrit un petit programme qui me rendait de biens grands services qui me convenait parfaitement (recup données site zeturf), hélas trois fois hélas, le site en question a dû sur injonction d'un autre opérateur cesser de données les cotes PMU. J'ai cherché sur le web, quel site pourrait palier à ce manque qui rend obsolète mon fichier excel. Après avoir trouvé ce site, je m'attèle à essayer de modifier le code pour éviter de revenir à la charge ici et même si j'arrive a me connecter sur ce site après avoir modifier quelques lignes de code, je suis confronté à deux problèmes, le 1er il récupère en plus des données de la date du jour les données de je ne sais combien de jours en arrière, et le 2eme problème c'est qu'il récupère pour toutes les journées que la 3e course, j'ai beau m'acharner dessus rien n'y fait, (ci joint le code modifié). Je vous sollicite donc pour avoir de l'aide pour comprendre le pourquoi du comment.
Grand merci par avance à ceux qui se pencheront sur mon problème
Cordialement
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 14/09/2010
' Sujet : Récup données Web ZEturf.fr
'---------------------------------------------------------------------------------------
Sub TraitementCotes()
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.turf-fr.com/cotes-pmu/"
'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, "/", "")) > 1 Then
T = Mid(T, Len(vURL) + 1)
SepareTitre T
RecupCotes 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(4, 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(5, 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, "/") > 5
.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 RecupCotes(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 = "10"
.WebFormatting = xlWebFormattingRTF
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
'Efface l'entête
End Sub
|
Didier FOURGEOT