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
| Sub Import()
'Il faut activé les références suivantes (Outils, Référence...)
'Microsoft XML, [n° de version]
'Microsoft HTML Object Library
Dim LaDate As String
Dim URLArchive As String
Dim URLCourse As String
Dim IEDoc As New HTMLDocument
Dim Req As New MSXML2.XMLHTTP
Dim DateReunion As Date
Dim AnneeMois As String
Dim Tab_Reunion As HTMLTable
Dim TmpElem As HTMLGenericElement
Dim TabRow As HTMLTableRow
Dim TabRowLieu As HTMLTableRow
Dim LienHy As Hyperlink
Dim TheCell As Range
'Initialisation
URLArchive = "http://www.turf-fr.com/archives/courses-pmu/"
'On prend en compte la date
'Il vaut mieux utiliser les codename (ici F1, F2, ...), plutot que d'utiliser sheets("...")
'2 avantages:
'Si l'utilisateur modifie le nom de l'onglet, ça ne change rien
'Si le classeur au 1er plan n'est plus celui qui contient la macro, elle continue à poiter sur celui-ci (sinon la macro utilise la classeur actif pour effectuer des modifs...
'autre solution pour éviter cette dernière situation et si tu veux vraiment utiliser sheets("..."), il faut préciser sur quel classeur tu travail
'ThisWorkBook.sheets("...")
If F1.Range("E12") = "Demain" Then
DateReunion = Date + 1
Else
DateReunion = Date
End If
'On crée le lien qui pointe vers la page récapitulative des réunion du mois
AnneeMois = Format(DateReunion, "yyyy/mmmm/")
URLArchive = URLArchive + AnneeMois
'On charge la page d'accueil en mémoire
With Req
.Open "GET", URLArchive, False
.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
.setRequestHeader "Accept-Encoding", "gzip , deflate"
'.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8" 'Ajouté
.setRequestHeader "Cache-Control", "max-age=0" 'Ajouté
.setRequestHeader "Accept-Language", "fr,fr-fr;q=0.8,en-us;q=0.5,en;q=0.3"
.setRequestHeader "Connection", "keep-alive" 'Modifié, espace retiré "keep -alive"
.setRequestHeader "Host", "www.turf-fr.com"
.setRequestHeader "Referer", URLArchive
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.0; rv:29.0) Gecko/20100101 Firefox/29.0"
.send
'On place la page dans le document
IEDoc.body.innerHTML = .responseText
End With
'On va chercher le lien vers la course (à adapter en fonction des besoins)
'On formate la date
LaDate = UCase(Format(DateReunion, "dddd d mmmm yyyy"))
'On recherche cette date dans le tableau contenu sur la page
'On pointe l'élément nommé le plus proche du tableau
Set TmpElem = IEDoc.getElementById("result_milieu")
'On pointe le tableau
Set Tab_Reunion = TmpElem.Children(6)
'On boucle sur les élément du tableau (Les Row) pour trouver les courses correspondantes à la date
For Each TabRow In Tab_Reunion.Children(1).Children
'Je ne sais pas si seul celles de vincennes t'interesse, il faudra peut-être adapter un peu
If UCase(TabRow.Children(0).innerText) = LaDate Then
'On verifie le lieu de la course
'On ne prend en compte que la 1ère réunion, celle qui vient donc en 1ère dans le tableau pour la date choisi
'If UCase(TabRow.Children(1).innerText) = "VINCENNES" Then
'On affiche l'ensemble des ligne de la feuille
Feuil3.Rows.Hidden = False
'C'est la reunion que l'on recherche
With Feuil3.QueryTables(1)
'On crée le lien
'On remplace "about:/" par la racine du site web "http://www.turf-fr.com/"
URLCourse = Replace(TabRow.Children(3).Children(0).href, "about:/", "http://www.turf-fr.com/")
'On remplace "arrivees" par "partants"
URLCourse = Replace(URLCourse, "arrivees", "partants")
.Connection = "URL;" & URLCourse
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True 'False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = True 'False
.WebDisableDateRecognition = True 'False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False 'True
'On format la feuille
'On masque les ligne contenant des liens (pour cacher les grosses cellules qui contiennent des lien sur plusieurs lignes)
With Feuil3
'On empeche le rafraichissement de l'écran, gain de temps et plus propre
Application.ScreenUpdating = False
'On ajuste la taille de lignes
.UsedRange.Rows.AutoFit
'On boucle sur les cellule de la colonne A
For Each TheCell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
With TheCell
'On laisse les liens qui ramènent en haut de page, on supprime les autres
If (UCase(.Value) <> "HAUT DE PAGE") And (.Hyperlinks.Count > 0) Then .EntireRow.Hidden = True
End With
Next
Application.ScreenUpdating = True
'On cache les lignes de début qui sont inutiles
.Range("A1", Feuil3.Columns(1).Find("COURSES", , xlValues, xlWhole, xlByColumns).Offset(-1)).EntireRow.Hidden = True
'On affiche la feuille Import
.Activate
End With
End With
'On quite la procedure
Exit Sub
'End If
End If
Next
End Sub |
Probleme vba excel
Répondre avec citation
Tutoriel : 
(Construire une adresse en tenant compte d'un numéro lui-même contenu dans cette même adresse 
, ça fait un peu pense aux Shadok tout ça 
ne vous gênez pas 
Envoyé par kiss6
Partager