Titre du sujet : Re: Récuperation données web
par myDearFriend! le 09/10/2010 00:48:32
Bonsoir jc24, le Forum,
Suite de nos précédents travaux donc... 
A vrai dire, je pense que je ne vais pas pouvoir me permettre de recommencer tout le travail accompli dans l'ancien fichier... d'autant que ce changement de site va certainement impliquer une révision complète de la façon d'aborder les problèmes...
Pour te venir en aide cependant, tu trouveras ci-joint une proposition qui devrait te permettre de re-partir sur la bonne voie. Dans ce nouveau classeur (que j'aurais préféré que tu joignes), la récupération des cotes pour les 5 premières courses de chaque réunion du jour. Je te laisse voir le reste...
J'ai revu le code de la façon suivante :
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 09/10/2010
' Sujet : Récup données Web Turf.fr
'---------------------------------------------------------------------------------------
Sub TraitementCotes()
Dim IE As InternetExplorer
Dim IEDoc As HTMLDocument
Dim Col As New Collection
Dim F As Worksheet
Dim T As String, URLrecherche As String
Dim L As Long
Const vURL As String = "http://www.turf-fr.com/cotes-pmu/"
'Masque d'URL à rechercher
T = Format(Date, "dddd-d-mmmm-yyyy")
URLrecherche = vURL & "*_" & T & "*.html"
'Creation nouvelle feuille de stockage
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.StatusBar = "PATIENTEZ... CONNEXION EN COURS !"
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 URLrecherche 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
MsgBox "Traitement terminé !"
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 = "4,7,10,13,16" '--> liste des tables à récupérer
.WebFormatting = xlWebFormattingRTF
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
End Sub
En espérant que ça puisse te dépanner.
Cordialement,
|
Didier FOURGEOT