Copie de données Internet (Problème de code)

**Nonno 94** · 25/10/2012, 07h09

Bonjour le Forum,

ne parvenant pas à modifier un code qui fonctionne pour copier certaines données dans des pages Internet mais pas pour en copier d'autres, je viens demander votre aide pour me dire quelle modification lui apporter pour qu'il accepte de copier ces données.

L'adresse de la page Internet est la suivante :

Cours AB SCIENCE | AB | Cotation Bourse Paris - Les Echos Bourse

Ce code fonctionne pour copier le Cours et le + HAUT :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Lire_Cours_Potentiels()
 
    Dim IE As New InternetExplorer
    Dim IEDoc As HTMLDocument
    Dim HtmlTag As IHTMLElementCollection
    Dim Valeur1 As String, Valeur2 As String
    Dim Cel As Range, I As Integer
 
    Sheets("Cours et Potentiels").Select
        ActiveSheet.Unprotect
 
    For Each Cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        IE.Navigate Cel
        IE.Visible = True
        Do Until IE.readyState = READYSTATE_COMPLETE
            DoEvents
        Loop
        Set IEDoc = IE.document
 
        Set HtmlTag = IEDoc.getElementsByTagName("td")
 
        Valeur1 = "N/A": Valeur2 = "N/A"
        For I = 0 To HtmlTag.Length + 1
 
            If HtmlTag.Item(I).innerText = "Cours" Then
                Valeur1 = HtmlTag.Item(I + 1).innerText         'Valeur1 = HtmlTag.Item(I + 1).innerText
 
              If HtmlTag.Item(I).innerText = "Cours" Then
                Valeur2 = HtmlTag.Item(I + 7).innerText       'Valeur2 = HtmlTag.Item(I - 1).innerText '
              End If
                Exit For
            End If
        Next I
        Cel.Offset(, 3) = Valeur1
        Cel.Offset(, 2) = Valeur2
    Next Cel
 
        IE.Visible = False
 
    Set HtmlTag = Nothing
    Set IEDoc = Nothing
    Set IE = Nothing
 
 
        IE.Visible = False
 
        Range("B1").Select
            ActiveSheet.Protect
 
                ActiveWorkbook.Save
 
End Sub

Modifié comme ci-dessous pour lire le Cours et l'Objectif,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
            If HtmlTag.Item(I).innerText = "Cours" Then
                Valeur1 = HtmlTag.Item(I + 1).innerText         'Valeur1 = HtmlTag.Item(I + 1).innerText
 
              If HtmlTag.Item(I).innerText = "Cours" Then
                Valeur2 = HtmlTag.Item(I + 22).innerText       'Valeur2 = HtmlTag.Item(I - 1).innerText '
              End If
                Exit For
            End If

Il copie bien le Cours mais pas l'Objectif dont il ne copie que le Nom et pas la Valeur !!

J'avoue ne pas comprendre la raison de ce "caprice" et vous demande donc de m'aider à résoudre ce problème.
Est-il par ailleurs possible de copier en même temps dans cette page le Cours, l'Objectif et le Potentiel ?

En vous remerciant pour votre aide et en vous souhaitant une bonne journée.

Cordialement.
Nonno 94.

**Oliv-** · 25/10/2012, 11h21

Salut
Cours AB SCIENCE | AB | Cotation Bourse Paris - Les Echos Bourse n'est pas une adresse internet mais le titre de la page !
une adresse commence par http

**Nonno 94** · 25/10/2012, 11h55

Bonjour Olivier et merci d'avoir pris la peine de répondre à ma question.

Je vous demande de bien vouloir excuser mon erreur mais je voulais communiquer le lien pour permettre de visualiser la page et repérer les données à sélectionner puis copier; à savoir :
- le Cours (14 € 70 à 11 h 33),
- l'Objectif de cours à trois mois (9,30 €) du tableau "CONSENSUS DES ANALYSTES"et éventuellement
- le Potentiel (-36,7 %) indiqué dans ce même tableau à la même heure.

Voici donc l'adresse de la page "Synthèse" de la valeur "AB SCIENCE" :

http://bourse.lesechos.fr/bourse/syn...PAR&codif=ISIN

Cordialement.
Nonno 94.

**pc75** · 25/10/2012, 14h12

Bonjour,

Une autre piste :

Tu peux récupérer le code html de la page avec

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
IEDoc.body.OuterHTML

Ensuite, à l'aide des fonctions inStr() et Mid(), tu peux t'en sortir.

**Oliv-** · 25/10/2012, 14h15

la valeur de "Objectif" n'est pas dans un <td> mais dans un <th>

tu peux soit utiliser firefox avec firebug pour voir dynamiquement la source de la page , ou avec IE 7/8 c'est OUTILS /"outils de développement" accessible par F12

Attention avec tes HtmlTag.Item(I + 7) faut être sûr que les infos ne changent pas de place !

un truc comme cela semble fonctionner pour objectif

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Lire_Cours_Potentiels()
 
    Dim IE As New InternetExplorer
    Dim IEDoc As HTMLDocument
    Dim HtmlTag As IHTMLElementCollection
    Dim Valeur1 As String, Valeur2 As String
    Dim Cel As Range, I As Integer
 
    Sheets("Feuil1").Select
    ActiveSheet.Unprotect
 
    For Each Cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        IE.Navigate Cel
        IE.Visible = True
        Do Until IE.readyState = READYSTATE_COMPLETE
            DoEvents
        Loop
        Set IEDoc = IE.document
 
        Set HtmlTag = IEDoc.getElementsByTagName("td")
 
        Valeur1 = "N/A": Valeur2 = "N/A"
        For I = 0 To HtmlTag.Length + 1
 
            If HtmlTag.Item(I).innerText = "Cours" Then
                Set Myvaleur1 = HtmlTag.Item(I + 1)
                Valeur1 = HtmlTag.Item(I + 1).innerText         'Valeur1 = HtmlTag.Item(I + 1).innerText
                Valeur2 = HtmlTag.Item(I + 7).innerText       'Valeur2 = HtmlTag.Item(I - 1).innerText '
 
            ElseIf HtmlTag.Item(I).innerText = "Objectif de cours à trois mois" Then
                Set Myvaleur3 = HtmlTag.Item(I)
                 Set THTag = Myvaleur3.parentElement.getElementsByTagName("th")
                Valeur3 = THTag.Item(0).innerText         'Valeur1 = HtmlTag.Item(I + 1).innerText
 
                Exit For
            End If
        Next I
        Cel.Offset(, 3) = Valeur1
        Cel.Offset(, 2) = Valeur2
        Cel.Offset(, 4) = Valeur3
        Cel.Offset(, 5) = Valeur4
    Next Cel
 
    IE.Visible = False
 
    Set HtmlTag = Nothing
    Set IEDoc = Nothing
    Set IE = Nothing
 
 
    IE.Visible = False
 
    '        Range("B1").Select
    '            ActiveSheet.Protect
    '
    '                ActiveWorkbook.Save
 
End Sub

**Nonno 94** · 25/10/2012, 14h55

Re-bonjour Oliv' et bonjour pc 75,

le code d'Oliv' ne semble pas fonctionner; il fonctionne ......parfaitement et répond tout à fait à ma demande.
Mes connaissances en VBA étant très limitées, je n'ai pu explorer la piste proposée par pc 75.

Je vous renouvelle mes remerciements et vous souhaite une très bonne fin de journée.

Cordialement.
Nonno 94.

**pc75** · 25/10/2012, 16h12

Re,

Pour info, une alternative (à condition que la mise en page ne change pas) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Go()
MyUrl = "http://bourse.lesechos.fr/bourse/synthese.jsp?code=FR0010557264&place=XPAR&codif=ISIN"
Set web = CreateObject("InternetExplorer.Application")
web.Navigate MyUrl
Do While web.Busy
Loop
On Error Resume Next
Set doc = Nothing
Do Until Not doc Is Nothing
    Set doc = web.Document
Loop
strWebPage = doc.body.OuterHTML
'web.Quit
GetData = strWebPage
Cours = "<td class=""b12-tab-int b12-tab-bold"">Cours</td>"
Pos = InStr(1, GetData, Cours, vbTextCompare) + Len(Cours)
Chaine = Mid(GetData, Pos)
Valorisation = InStr(1, Chaine, "valorisation"">", vbTextCompare) + Len("valorisation"">")
Pos = InStr(111, Chaine, "</TD>") - Valorisation
Cours = Mid(Chaine, Valorisation, Pos)
MsgBox "Cours = " & Cours
 
Objectif = "<td>Objectif de cours à trois mois</td>"
Pos = InStr(1, Chaine, Objectif, vbTextCompare) + Len(Objectif)
Chaine = Mid(Chaine, Pos)
Objectif = "<TH style=""FONT-WEIGHT: normal"">"
FinPos = InStr(1, Chaine, Objectif, vbTextCompare) + Len(Objectif) - 1
Chaine = Mid(Chaine, 1 + FinPos)
Objectif = Mid(Chaine, 1, InStr(1, Chaine, "</TH", vbTextCompare) - 2)
MsgBox Objectif
 
Potentiel = "b12-rouge"
Pos = InStr(1, Chaine, Potentiel, vbTextCompare) + Len(Potentiel) + 1
Chaine = Mid(Chaine, Pos)
Pos = InStr(1, Chaine, "</TH>") - 1
Potentiel = Mid(Chaine, 1, Pos)
MsgBox Potentiel
web.Quit
 
End Sub

**Nonno 94** · 01/11/2012, 18h19

Bonsoir et merci pour ce code qui, naturellement, fonctionne parfaitement.

Ainsi que vous le savez, il doit remplacer le code que j'utilise actuellement avec d'autres dans une macro qui en regroupe plusieurs autres pour mettre à jour le fichier.
Nouvelle difficulté insurmontable pour moi : je suis incapable de remplacer mon ancienne macro par les vôtres écrits dans un langage différent de celui des autres macros et que je ne comprends malheureusement pas !!
Je suis vraiment dépité.

Voici le code que j'utilise actuellement et qui doit être remplacé par les vôtres :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Lire_Cours_Objectifs_Potentiels_2()
 
    Dim IE As New InternetExplorer
    Dim IEDoc As HTMLDocument
    Dim HtmlTag As IHTMLElementCollection
    Dim Valeur1 As String, Valeur2 As String
    Dim Cel As Range, I As Integer
 
Sheets("Potentiels (S)").Select
    ActiveSheet.Unprotect
 
    For Each Cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        IE.Navigate Cel
        IE.Visible = True
        Do Until IE.readyState = READYSTATE_COMPLETE
            DoEvents
        Loop
        Set IEDoc = IE.document
 
        Set HtmlTag = IEDoc.getElementsByTagName("td")
 
        Valeur1 = "N/A": Valeur2 = "N/A"
        For I = 0 To HtmlTag.Length + 1
 
            If HtmlTag.Item(I).innerText = "Cours" Then
                Set Myvaleur1 = HtmlTag.Item(I + 1)
                Valeur1 = HtmlTag.Item(I + 1).innerText         'Cours
                'Valeur2 = HtmlTag.Item(I + 7).innerText         '+ HAUT
 
            ElseIf HtmlTag.Item(I).innerText = "Objectif de cours à trois mois" Then
                Set Myvaleur3 = HtmlTag.Item(I)
                 Set THTag = Myvaleur3.parentElement.getElementsByTagName("th")
                Valeur3 = THTag.Item(0).innerText               'Objectif
                    Set Myvaleur4 = HtmlTag.Item(I + 1)
                        Set THTag = Myvaleur4.parentElement.getElementsByTagName("th")
                        Valeur4 = THTag.Item(0).innerText       'Potentiel
 
                Exit For
            End If
        Next I
        Cel.Offset(, 37) = Valeur1
        'Cel.Offset(, 3) = Valeur2
        Cel.Offset(, 6) = Valeur3
        Cel.Offset(, 1) = Valeur4
    Next Cel
 
    IE.Visible = False
 
    Set HtmlTag = Nothing
    Set IEDoc = Nothing
    Set IE = Nothing
 
 
    IE.Visible = False
 
           Range("B1").Select
                ActiveSheet.Protect
 
                   ActiveWorkbook.Save
 
End Sub

Ci-dessous les autres Macros qui participent à la mise à jour du fichier.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub MAJ()
'
' MAJ Macro
' Macro enregistrée le 02/09/2012 par Edmond
'

'
        Semaine_précédente_Objectifs_EV
        
        Semaine_précédente_Objectifs
        
        'Effacer_Objectifs

        Semaine_précédente_Potentiels
        
    Lire_Cours_Objectifs_Potentiels_2
        
        Objectifs_Copie
        
        Objectifs_JDF_Copie
        
        Cours_Consensus_Copie
        
        Cours_3_mois_2
        
        Consensus_Copie
        
        Objectifs_3_mois_2
        
        Ecarts_Classement

        Date_MAJ

        Colorer_Onglet
        
           MsgBox "La Mise à jour des Potentiels et des Objectifs à 3 mois des CONSENSUS est terminée." & Chr(10) & _
                    "Vérifier qu'elle s'est effectuée correctement." & Chr(10) & _
                    "Si tel est le cas, fermer le Fichier pour l'enregistrer et créer une Copie " & Chr(10) & _
                    "puis ouvrir le Fichier 'Conseils SRD' pour télécharger les CONSEILS actualisés du guide 'SRD' des 'Echos'et mettre à jour" & Chr(10) & _
                    "les Conseils, Risques et Objectifs à 18 mois de ce Fichier. " & Chr(10), vbInformation, "CONSENSUS 'Les Echos': Potentiels et Objectifs 3 mois."

        ActiveWorkbook.Save

End Sub

La macro Lire_Cours_Objectifs_Potentiels_2 doit être remplacée par vos codes !!!

Je vous joins un fichier d'essai qui vous permettra, je l'espère, de redresser la situation !!!!

Je suis dépité.

Bonne soirée.
Cordialement.

Nonno 94.

**patricktoulon** · 02/11/2012, 12h23

bonjour nono

alors tu m'excusera mais c'est ni fait ni a faire

je n'y comprend rien dans ton truc
aucunne explication

tu n'a meme pas essayé d'intégrer les feuille tel que je te les avais rendues

c'est une catastrophe

bon je vais essayer de faire quelque chose mais en l'etat ca va etre difficile

je voudrais au moins que tu essaie d'analyser mon code

et que tu vois ce que tu aurais pu faire pour les au moins 200 pages synthezes

sachant que le code est commenté tu aurais du y arriver

peut etre t'es tu lancé dans une entreprise hors de ta portée

c'est temeraire j'aime ca mais il faut le faire avec methode

en tout cas moi je vire tout tes codes car ya rien a garder

je reprend tout a zero

ensuite il faudrai que tu m'explique quelle valeur va ou

les colonne ne sont plus au meme encroits

enfin si je devais traviller dans le bon sens il y aurais qu'a recupérer les lien syhtheses(210 apeu pres )et les autre
tout le reste est a jetter

bon apres ma crise de colere
donne mois une page vide avec des bulles qui me disent a quoi corespondent les cellules

en plus je viens de me rendre compte que tu n'a meme pas ecouté ce que je t'ai dis
pas de virgule dans les noms de sheets c'est pourtant pas compliqué sinon trop de probleme dans le code
je ne retrouve rien de ce que je t'ai fait dans ton fichier

a plus

**patricktoulon** · 02/11/2012, 18h13

bonsoir

après ma petite crise de ce matin je reviens avec de bonnes nouvelles

voila ton fichier nettoyé,vidé,expurgé,décrassé,décapé

toujours une seule fonction pour les données
j'ai supprimé tout tes modules a dormir debout sauf le module 1
qui te sert pour les autres pages

voila je t'ai mis aussi un pseudo progressbars pour avoir un aperçu de l'état du telechargement juste pour le fun

et essaie d'apprendre un peu c'est pas difficile

dis moi ce que tu en pense ???

récupère le vite je ne le laisserais pas

au plaisir

**Nonno 94** · 04/11/2012, 17h24

Bonjour Patricktoulon,

c'est avec surprise que je découvre votre message et le nouveau fichier au retour de plusieurs jours "déconnectés".
Je vous en remercie et vais donc essayer de faire le ménage dans mon "bric à brac" (sic). "Ce n'est pas gagné !".
Je suis désolé de vous avoir déçu. Ne croyez-pas que je ne fasse pas d'efforts pour progresser dans un domaine dans lequel vous excellez; je "m'accroche" mais c'est difficile.
Je vais donc décortiquer ce nouveau fichier pour essayer d'en comprendre les subtilités.

Une nouvelle fois, mille mercis pour ce chef-d'oeuvre.

Cordialement.
Nonno 94.

**Oliv-** · 04/11/2012, 21h01

nonno,
En fait tu doubles les difficultés, le vba n'est peut être pas la partie la plus compliquée quand tu veux récupérer des données de pages internet, il faut surtout décortiquer le HTML !
Il y a un logiciel fort intéressant à ce sujet : imacros il y a un add on pour firefox

Copie de données Internet (Problème de code) [XL-2003]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager