Titre du sujet : Re: Modification d'un code Vba (mDF RecupWeb Geny.com)
par myDearFriend! le 24/10/2011 11:56:13
Bonjour chakir123, le Forum,
Tu vois quand tu veux... 
Bon, tu trouveras en pièce jointe une réponse à ta demande.
J'ai modifié le code VBA comme suit :
Option Explicit
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 24/10/2011
' Sujet : Récup données Web : Geny.com (v1.1)
'---------------------------------------------------------------------------------------
Sub ListeCourses(Optional Dem As Boolean)
Dim IE As InternetExplorer
Dim IEdoc As HTMLDocument
Dim O As Object
Dim vUrl As String, T As String
Dim Lmax As Long, L As Long
'Prépare la feuille
Application.StatusBar = "Patientez..."
ActiveSheet.Range("17:100").Delete
Application.ScreenUpdating = False
'URL de départ http://www.geny.com/reunions-courses-pmu/_d2011-10-25?
vUrl = "http://www.geny.com/reunions-courses-pmu" & IIf(Dem, Format(Date + 1, "/_\dyyyy-mm-dd?"), "")
'Ouvre la page web dans IE de façon invisible
Set IE = CreateObject("internetExplorer.Application")
IE.Visible = False
'Ouvrir la page Web
IE.Navigate vUrl
Do Until IE.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
Set IEdoc = IE.Document
vUrl = "http://www.geny.com/partants-pmu/"
'Mémoriser les liens utiles
With ActiveSheet.ComboBox1
.Clear
.ColumnCount = 2
.BoundColumn = 2
.Style = fmStyleDropDownList
.AddItem "< choisir une course >"
Lmax = IEdoc.Links.Length
For Each O In IEdoc.Links
L = L + 1
Application.StatusBar = "Patientez... " & L * 100 \ Lmax & " %"
If O.href Like vUrl & "*" Then
T = Mid(O.href, Len(vUrl) + 1)
T = Left(T, InStrRev(T, "_") - 1)
.AddItem T
.List(.ListCount - 1, 1) = O.href
End If
Next O
.ListIndex = 0
End With
'Quitter IE
Set IEdoc = Nothing
IE.Quit
Set IE = Nothing
Application.ScreenUpdating = True
MsgBox "Liste mise à jour avec succès !" & vbLf & vbLf & "- Choisissez une course dans la liste," & vbLf & "- Cliquez ensuite sur « Stats Partants » " & vbLf & "- Puis, patientez ... ", vbInformation + vbOKOnly, "myDearFriend! - www.mdf-xlpages.com"
Application.StatusBar = False
End Sub
Sub RecupPartants()
Dim Plage As Range
Dim TabTemp As Variant
Dim vUrl As String
Dim DernLign As Long, L As Long, Lmax As Long
Dim DernCol As Integer
Application.ScreenUpdating = False
With ActiveSheet
'Récupère tableau des partants
.Range("17:100").Delete
With .ComboBox1
If .ListIndex < 1 Then Exit Sub
vUrl = .Value
End With
Application.StatusBar = "Patientez..."
With .QueryTables.Add(Connection:="URL;" & vUrl, Destination:=.Range("B17"))
.Name = "mDFquery"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "tableau_partants"
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = False
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
'Récupére la carrière de chaque cheval
DernCol = .Cells(18, .Columns.Count).End(xlToLeft).Column
DernLign = .Cells(.Rows.Count, 2).End(xlUp).Row
Set Plage = .Range(.Cells(19, 2), .Cells(DernLign, DernCol + 3))
TabTemp = Plage.Value
Lmax = UBound(TabTemp)
For L = 1 To Lmax
Application.StatusBar = "Patientez... " & L * 100 \ Lmax & " %"
vUrl = Plage.Cells(L, 2).Hyperlinks(1).Address
RecupCarriere vUrl, DernLign + 1
TabTemp(L, DernCol) = .Cells(DernLign + 2, 3)
TabTemp(L, DernCol + 1) = .Cells(DernLign + 2, 4)
TabTemp(L, DernCol + 2) = .Cells(DernLign + 2, 5)
Next L
Plage.Value = TabTemp
'Mise en forme
.Range(.Cells(DernLign + 1, 3), .Cells(DernLign + 1, 5)).Copy Destination:=.Cells(Plage(1).Row - 1, DernCol + 1)
.Range(DernLign + 1 & ":1000").Delete
.Columns(DernCol).Copy
.Range(.Cells(1, DernCol + 1), .Cells(1, DernCol + 3)).EntireColumn.PasteSpecial Paste:=xlPasteFormats
.Cells.Hyperlinks.Delete
With Plage.Borders()
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.Cells.EntireColumn.AutoFit
.Cells(17, 2).Select
End With
Application.ScreenUpdating = True
Application.StatusBar = False
Beep
End Sub
Sub RecupCarriere(vUrl As String, Lign As Long)
With ActiveSheet
.Range(Lign & ":1000").Delete
With .QueryTables.Add(Connection:="URL;" & vUrl, Destination:=.Cells(Lign, 2))
.Name = "mDFquery"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingRTF
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = False
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End With
End Sub
Je pense que ça devrait répondre à ton besoin...
Cordialement,
|
Didier FOURGEOT