1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
| Sub Traitement()
Dim vUrl As String
Dim D As String, NumCourse As String
With Sheets("Accueil")
D = .Range("E2").Text
NumCourse = .ComboBox1.Text
End With
If Not IsNumeric(NumCourse) Then Exit Sub
'URL de départ
vUrl = "http://www.pmu.fr/pmu/servlet/pmu.web.servlet.www.infos.PerformancesDetaillesServlet?dd=" _
& D & "&idc=" & NumCourse & "&np=1&ppd=0"
'Traiter
RecupChevaux vUrl
End Sub
Private Sub RecupChevaux(ByVal vUrl As String)
Dim IE As InternetExplorer
Dim O As Object, OI As Object, OIS As Object
Dim L As Long
'Ouvre la page web dans IE de façon invisible
Set IE = CreateObject("internetExplorer.Application")
IE.Visible = False
'RAZ de la feuille
ActiveSheet.Cells.Delete
Application.ScreenUpdating = False
On Error Resume Next
'Boucle sur l'ensemble des partants
Do
If vUrl = "" Then
'Bouton "Suivant" sur la page Web ?
For Each OI In IE.Document.Links
If OI.Title = "Suivant" Then
vUrl = OI.href
End If
Next OI
End If
If vUrl = "" Then Exit Do 'Sortir à la fin
'Ouvrir la page Web
IE.Navigate vUrl
Do Until IE.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
'Détermine première ligne libre
L = Cells(Rows.Count, 1).End(xlUp).Row + 3
'Récup Nom du partant
Set O = IE.Document.getElementsByTagName("H1")
For Each OI In O
L = L + 1
With Cells(L, 1)
.Value = OI.innerText
.Font.Bold = True
Application.StatusBar = .Value
End With
Next OI
'Récup Détail du partant
Set O = IE.Document.getElementsByTagName("P")
For Each OI In O
If OI.innerText <> " Retour à l'accueil de pmu.fr" Then
Set OIS = OI.getElementsByTagName("span")
L = L + 1
With Cells(L, 1)
.Value = OIS.Item(0).innerText
End With
With Cells(L, 2)
.Value = OIS.Item(1).innerText
End With
End If
Next OI
L = L + 1
Cells(L, 1) = "Gains 6 dernières courses"
Cells(L, 2).Value = RecupPlusDetails(L, vUrl)
vUrl = ""
Loop
Columns(1).AutoFit
ActiveSheet.UsedRange.HorizontalAlignment = xlLeft
Application.ScreenUpdating = True
'Fermer IE
IE.Quit
Set IE = Nothing
Application.StatusBar = False
End Sub
Private Function RecupPlusDetails(Lign As Long, vUrl As String) As String
Dim T As String
Dim L As Byte
With Sheets("Tempo")
.Cells.Delete
With .QueryTables.Add(Connection:="URL;" & vUrl, Destination:=.Cells(1, 1))
.Name = "LaRequete"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "1"
.WebFormatting = xlWebFormattingNone ' xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
For L = 1 To 6
T = T & Val(.Cells(L * 3 + 1, 3).Value) & "-" 'Recup Allocation
Next L
RecupPlusDetails = Left(T, Len(T) - 1)
For L = 1 To 6
T = T & Val(.Cells(L * 3 + 2, 6).Value) & "-" ' recup Gains
Next L
RecupPlusDetails = Left(T, Len(T) - 2)
For L = 1 To 6
T = T & Val(.Cells(L * 3 + 2, 1).Value) & "-" ' Recup Nb Partants
Next L
RecupPlusDetails = Left(T, Len(T) - 1)
[B]For L = 1 To 6
T = T & Val(.Cells(L * 3 + 1, 1).Value) & "-" ' >>>>> Recup Date derniére course ( probléme) <<<<<<<<<<<<
Next L
RecupPlusDetails = Left(T, Len(T) - 1)
End With
End Function |
Probléme macro recup web-format date
Répondre avec citation
Envoyé par koni77
ci-dessous.
Partager