Titre du sujet : Re: Regrouper les données Zeturf
par myDearFriend! le 28/09/2010 22:05:25
Bonsoir jc24,
Tu trouveras en pièce jointe mon interprétation de ta demande...
En reprenant pour base le fichier réalisé pour ton fil précédent :
Cette fois, le bouton vert permet de récupérer à la fois les Rapports et les Pronos en amont.
Cela dit, j'avoue que j'ai un peu de mal à comprendre ta façon d'aborder la chronologie des évènements... Vouloir récupérer les pronos à postériori (après résultats des courses !), c'est une logique qui m'échappe.
Pour info, j'ai modifié le module de code "ModRapports" comme suit afin d'imbriqué les 2 traitements :
Option Explicit
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 28/09/2010
' Sujet : Récup données Web ZEturf.fr
'---------------------------------------------------------------------------------------
Sub TraitementRapportsEtPronos()
Dim F As Worksheet
Dim Plage As Range, R As Range
Dim Lien As String, D As String
Const vURL As String = "http://www.zeturf.fr/fr/resultats/"
Const vURL2 As String = "http://www.zeturf.fr/fr/programme/"
For Each F In Worksheets
With F
If Right(F.Name, 2) = " ®" Then
'Si onglet <> aujourd'hui
D = Replace(.Name, " ®", "")
If DateValue(D) <> Date Then
'Préparer la feuille cible
.Activate
.Columns("K:IV").Delete Shift:=xlToLeft
Application.ScreenUpdating = False
'Récup des données web
Set Plage = .Range(.Cells(4, 1), DernCell.Offset(-1, 0)).SpecialCells(xlCellTypeBlanks)
For Each R In Plage
Lien = R.Offset(0, 1).Text
If InStr(1, Lien, "/") > 0 Then
Application.StatusBar = Lien
RecupRapports vURL & Lien, R.Offset(-2, 10)
RecupPronos vURL2 & Lien, R.Offset(1, 20)
End If
Next R
'mise en forme
.Range("K:N,Q:Q,S:S").Delete Shift:=xlToLeft
.Columns("K:P").EntireColumn.AutoFit
.Range("A1").Select
'Renommer l'onglet (supprimer le tag '®')
.Name = D
Application.ScreenUpdating = True
End If
End If
End With
Next F
Application.StatusBar = False
Beep
End Sub
Sub RecupRapports(vURL As String, R As Range)
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"
.WebFormatting = xlWebFormattingRTF
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
'Efface l'entête
R.Resize(3, 9).ClearContents
End Sub
Sub RecupPronos(vURL As String, R As Range)
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 = "5"
.WebFormatting = xlWebFormattingRTF
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
End Sub
J'espère que ça pourra te convenir.
Cordialement,
Nb: à l'attention des visiteurs intéressés : le classeur en pièce jointe exploite des requêtes web via le navigateur Internet Explorer. Ceci explique notamment pourquoi il ne fonctionne pas sous environnement Mac.
|
Didier FOURGEOT