Salutations à vous, lecteurs !
Si vous êtes sur un MAC, l'astuce fonctionne uniquement sur Windows, désolé …
Si vous n'êtes pas développeur, comme le disait Michel (Colucci) : « Circulez, y a rien à voir ! »
J'entends par développeur, non pas une personne dont c'est forcément le métier, mais quelqu'un
ayant des connaissances de programmation en langage VB et dérivés comme ici le VBA et le VBScript,
prenant le temps d'analyser un problème, consultant l'aide intégrée au VBA d'Excel
ou allant chercher l'information dans MSDN, sachant adapter une procédure à ses besoins …
Merci de ne pas polluer cette discussion si vous n'arrivez pas à adapter cette astuce,
créez votre discussion dans le sous-forum Macros et VBA Excel afin d'y présenter clairement vos difficultés …
Pour récupérer des données sur des pages Web, mieux vaut éviter le pilotage d'Internet Explorer
car c'est la manière la plus lente et souvent fastidieuse, bref à utiliser en dernier recours …
Si la page Web s'y prête, Excel est doté depuis longtemps d'une méthode pour effectuer une requête sur le Web,
soit directement depuis le menu d'une feuille de calculs soit au sein d'une procédure VBA (QueryTable).
Cette méthode est très pratique lorsque les données sont organisées en tableau par exemple, mais si
les données se trouvent sur plusieurs pages Web, elle s'avère lente aussi, certes moins que l'instanciation d'IE
mais bien moins rapide que d'utiliser une librairie comme par exemple MSXML2 …
Récemment j'ai eu le cas d'un résultat d'une requête sur un site financier réparti sur 101 pages web !
Le site étant assez véloce, moins d'une minute est nécessaire pour récupérer les données de toutes ces pages
par l'utilisation d'une telle librairie alors qu'il en faut presque dix via de multiples QueryTable !
(Les temps au fil de cette discussion n'y sont qu'à titre indicatif car ils varieront selon la configuration du PC,
la version d'Excel et la rapidité de la connexion Internet …)
Mais dans le cas d'un site lent, la durée se chiffre en minutes …
Et si le temps d'exécution pouvait être encore divisé par deux au moins ?
- Avant principe, une p'tite histoire …
La reine d'une colonie a confié la récolte journalière d'un nectar particulier à l'une de ses abeilles.
Les aller-retour entre chaque fleur et le nid épuisant cette dernière, la reine de lui dire :
« Tu es responsable de la récolte de ce divin nectar, mais tu as le droit de te faire aider par tes sœurs ! »
Par analogie, une abeille est une procédure et une fleur, une page Web,
tout comme le nectar est une donnée et le nid, une feuille de calculs d'un classeur Excel …
Au lieu de laisser une procédure mono-tâche s'acquitter à elle seule de récupérer les données séquentiellement
dans chaque page Web une à une, mieux vaut lancer en parallèle autant de procédures que de pages Web !
Une procédure VBA, mono-tâche, lance des requêtes VBScript sous Windows, multi-tâches lui …
Si vous ne disposez pas de droits d'accès suffisants, comme souvent le cas en entreprise,
il se peut qu'il faille autoriser la procédure VBScript ou être dans l'impossibilité de l'exécuter !
Le nombre de procédures VBScript est limité par la taille disponible au sein de la mémoire vive
mais une procédure occupant environ 4Mo de RAM, il y a de la marge !
L'exécution peut être ralentie par d'autres applications actives comme une messagerie par exemple …
- Avant illustration, démonstration de la procédure mono-tâche.
Prenons le cas concret de
parisdauphine dans sa discussion
récupérer des données Internet
devant, dans les pages Web d'un site lent en liens hypertexte en colonne A,
extraire une date et la placer en colonne E, la fameuse cinquième colonne …
Les codes suivants sont situés dans le module de la feuille de calculs contenant les données.
Face à la lenteur du site et aux milliers de liens, la procédure traite une page écran à la fois depuis la position de la ligne
de la cellule active, si la cellule en colonne A contient un lien hypertexte et si la date n'est pas renseignée en colonne E.
Voir la procédure
Demo utilisant la librairie MSXML2, la progression des pages étant indiquée en bas à gauche
dans la barre d'état, un message indiquant la durée du traitement ponctuant la fin de cette procédure :
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
| Const TITRE$ = " Récupération de dates"
Private Declare Function InternetCheckConnectionA Lib "Wininet" (ByVal SITE$, ByVal one&, _
ByVal zero&) As Boolean
Function WebOK(Optional ByVal URL$ = "http://www.msn.com") As Boolean
P& = InStr(9, URL, "/"): If P Then URL = Left$(URL, P)
WebOK = InternetCheckConnectionA(URL, 1, 0)
End Function
Function WebExtract$(PAGE$, ByVal AFTER$)
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", PAGE, False
.send
If .Status = 200 Then
SP = Split(.responseText, AFTER)
If UBound(SP) > 0 Then WebExtract = Split(SP(1), "<")(0)
End If
End With
End Function
Private Sub Demo()
S = Timer: R& = ActiveCell.Row: If Cells(R, 1).Hyperlinks.Count = 0 Then Beep: End
If WebOK(Cells(R, 1).Hyperlinks(1).Address) = False Then Beep: End
Me.Shapes("Boutons").Visible = False: ActiveWindow.ScrollRow = R
For R = R To R + ActiveWindow.VisibleRange.Rows.Count - 2
If Cells(R, 5).Value = "" And Cells(R, 1).Hyperlinks.Count Then
P% = P% + 1
Application.StatusBar = "Page " & P
Cells(R, 5).Value = WebExtract(Cells(R, 1).Hyperlinks(1).Address, _
"End of placement</td><td>")
End If
Next
If P Then
S = Format(Timer - S, " (0.000s)"): Application.StatusBar = False
Debug.Print "Demo" & S: MsgBox "Opération achevée …" & S, vbInformation, TITRE
Else
Beep
End If
Me.Shapes("Boutons").Visible = True: End
End Sub |
Le site nécessitant environ 4 secondes par page, cette procédure a besoin de plus de 120 secondes pour 31 lignes …
Et si les abeilles s'en mêlent ?
- Illustration, Let It Bee !
L'heureuse parisdauphine va récupérer une procédure sur mesure encore plus véloce !
Quoique pas si chanceuse vu son Office ou son ordinateur lui jouant de sales tours …
Cette astuce utilise la même librairie mais cette fois-ci en multi-tâches via Windows.
Tout comme le fameux film de Tarentino, elle est scindée en deux parties :
la première ascendante (LetItBee), après la génération du fichier VBScript, lui transmet l'adresse de chaque page Web
et la cellule en retour, la seconde descendante via l'évènement Worksheet_Change après chaque mise à jour
décompte les procédures en cours de traitement. Ne pas s'inquiéter s'il paraît ne rien se passer,
suivre l'évolution toujours dans la barre d'état, les données vont finir par arriver groupées !
A noter la fin identique au film …
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
| Const TITRE$ = " Récupération de dates"
Private BeeC%, BeeL$, BeeT!
Sub AfficheBoutons(Optional BeeMIA As Boolean = True)
Me.Shapes("Boutons").Visible = True: Application.StatusBar = False
If BeeMIA Then MsgBox "Bee Missing In Action !" & vbLf & vbLf & "Vérifiez les liens, " & _
"la lenteur de réponse du site …", vbExclamation, TITRE
On Error Resume Next
Kill BeeL: End
End Sub
Sub Been(SHEDULE As Boolean)
Static TS
If SHEDULE Then TS = Now + 0.0007
Application.OnTime TS, Me.CodeName & ".AfficheBoutons", , SHEDULE
End Sub
Private Sub LetItBee()
BeeT = Timer: Me.Shapes("Boutons").Visible = False: Been True
With ThisWorkbook
BeeL = .Path & "\Bee - " & Split(.Name, ".")(0) & " - " & Me.Name & " .vbs"
SC = Array("On Error Resume Next", "With CreateObject(""MSXML2.XMLHTTP"")", _
"If Err.Number Then WScript.Quit 1", _
".open ""POST"",WScript.Arguments(0),False", _
"If Err.Number Then WScript.Quit 2", ".send", "If .status=200 Then " & _
"SP=Split(.responseText,""End of placement</td><td>""): " & _
"If UBound(SP)>0 Then T=Split(SP(1),""<"")(0)", "End With", _
"GetObject(,""Excel.Application"").Workbooks(""" & .Name & _
""").Worksheets(""" & Me.Name & """)." & _
"Range(WScript.Arguments(1))" & ".Value=T")
End With
F% = FreeFile
Open BeeL For Output As #F
Print #F, Join(SC, vbNewLine)
Close #F
SC = """" & BeeL & """ ": R& = ActiveCell.Row: ActiveWindow.ScrollRow = R
With CreateObject("WScript.Shell")
For R = R To R + ActiveWindow.VisibleRange.Rows.Count - 2
If Cells(R, 5).Value = "" And Cells(R, 1).Hyperlinks.Count Then
.Run SC & Cells(R, 1).Hyperlinks(1).Address & " " & Cells(R, 5).Address
BeeC = BeeC + 1: Application.StatusBar = "Let It Bee : " & Format(BeeC, "@@")
End If
Next
End With
If BeeC = 0 Then Been False: Beep: AfficheBoutons False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If BeeC And Target.Column = 5 Then
BeeC = BeeC - 1: Application.StatusBar = "Let It Bee : " & Format(BeeC, "@@")
If BeeC = 0 Then
S$ = Format$(Timer - BeeT, " (0.000s)"): Been False: Debug.Print "LetItBee" & S
MsgBox "Opération achevée …" & S, vbInformation, TITRE: AfficheBoutons False
End If
End If
End Sub |
Pour 31 lignes, cette astuce a besoin d'à peine 20 secondes, au moins 6 fois moins !
Les temps de chaque procédure figurent aussi dans la fenêtre Exécution de l'environnement VBA …
- En pièce jointe un fichier contenant les liens hypertexte et un bouton par procédure.
Espérant cette astuce vous apporte de la célérité dans vos applicatifs
et vous avoir fait sourire avec l'une des références disséminées !
♫ There is still a chance that they will see ♪
♪ There will be an answer, let it be ♫
♫ Let it be, let it be, let it be, let it be ♪
Accélérer une requête sur des multiples pages Web
Répondre avec citation
: ça peut servir aux autres 
Envoyé par Marc-L
Partager