Titre du sujet : Regrouper les données Zeturf par jc24 le 28/09/2010 13:26:52
Bonjour Didier, bonjour à tous,
J'ai mis mon silence à profit pour potasser et j'espère progresser dans la programmation VBA, je suis pas trop mécontent e moi puisque grâce à toi, Didier, j'ai réussi en prenant exemple sur ton code a récupérer d'autres données sur le site Zeturf, mais j'arrive pas à faire figurer toutes les données sur la même page, en effet je récupére les cotes et les rapports sur un fichier (celui que tu m'as créé, que j'appelle fichier 1) et je récupére les autres données sur un autre fichier, le problème se situe dans la mise en forme de ce dernier fichier puisque si il me récupére bien les données voulues la mise en page ne correspond pas a celle du 1er fichier (voir PJ1). L'idéal serait qu'un même fichier récupère les 3 données (côtes, rapports et pronostic). Je joins le code du 2e fichier.
Sub TraitementProno()
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.zeturf.fr/fr/programme/"
'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, "/", "")) > 5 Then
T = Mid(T, Len(vURL) + 1)
SepareTitre T
RecupProno 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(1, 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(1, 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, "/") > 0
.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 RecupProno(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 = "5"
.WebFormatting = xlWebFormattingRTF
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
End Sub
J'ai beau bidouillé je n'arrive pas à faire correspondre les données en copiant les données du fichier 2 sur le fichier 1
Merci de votre aide
Cordialement
|