Titre du sujet : Re: Besoin d'aide
par myDearFriend! le 09/09/2010 22:40:24
Bonsoir jc24, le Forum,
Tu trouveras en pièce jointe une interprétation de ta demande.
Pour info, j'ai utilisé le code VBA suivant (dans un module de code standard) :
Option Explicit
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 09/09/2010
' Sujet : Récup données Web ZEturf
'---------------------------------------------------------------------------------------
Sub Traitement()
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/cotes/"
'Creation nouvelle feuille de stockage
T = Format(Date, "dd-mm-yyyy")
On Error Resume Next
Set F = Sheets(T)
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
RecupCotes Col(L)
SepareTitre
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(Optional 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 = True
.Name = "Verdana"
.Size = 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 = "3"
.WebFormatting = xlWebFormattingRTF
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
'Efface l'entête
R.Resize(3, 1).EntireRow.Delete
End Sub
En espérant que ça puisse répondre à ton besoin...
Cordialement,
Nb: je prends 5% des gains ! 
|
Didier FOURGEOT