Récupérer des données Internet

**parisdauphine** · 22/12/2013, 11h28

Bonjour,
je souhaite récupérer une donnée qui existe sur plusieurs pages d'un même site Internet,
exemple des pages:
http://cbonds.com/emissions/issue/45650
http://cbonds.com/emissions/issue/45646
http://cbonds.com/emissions/issue/45648
http://cbonds.com/emissions/issue/45754
etc
ces différents liens des pages sont stockées dans des cellules excel (A1:A9000)
y'a 9000 liens

j'aurai besoin de récupérer la date correspondant à "end of placement"

je cherche un prog qui pourrai automatiser tout ça, merci de votre aide

**spookyz** · 22/12/2013, 13h36

Bonjour,
essaye ça

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
Public htmlDoc As MSHTML.HTMLDocument
Public IE As New SHDocVw.InternetExplorer
 
Sub JamesBonds()
'si les liens sont sur la premiere colonnes de la feuille actives
derli = Cells(65000, 1).End(xlUp).Row
 
    For i = 1 To derli
    navurl = Cells(i, 1)
 
        IE.navigate navurl
 
        Do While IE.readyState <> READYSTATE_COMPLETE
            DoEvents
        Loop
    'ici mettre true pour afficher internet explorer
IE.Visible = False
 
 
    Set htmlDoc = IE.document
 
TBL = htmlDoc.getElementsByTagName("table")
itm = TBL.all.Length
 
        For j = 1 To itm
        endofplac = TBL.all.Item(j).innerText
 
            If endofplac = "End of placement" Then
                dt = TBL.all.Item(j + 1).innerText
                Cells(i, 2) = endofplac
                Cells(i, 3) = dt
 
                Exit For
 
            End If
        Next j
    Next i
End Sub

cordialement

**parisdauphine** · 22/12/2013, 14h20

Merci Bcp, mais il y'a un message qui s'affiche "erreur de compilation, type défini par l'utilisateur non défini" concernant la première ligne (Public htmlDoc As MSHTML.HTMLDocument)

**spookyz** · 22/12/2013, 14h38

Pour manipuler IE, il nous faudra activer deux références : « Microsoft Internet Controls » et « Microsoft HTML Object Library ». Pour accéder aux références dans VBA, menu Outils -> Références.

http://qwazerty.developpez.com/tutor...-et-vba-excel/

**parisdauphine** · 22/12/2013, 15h19

C'est fait, maintenant il affiche autre chose "Variable objet ou variable de bloc With non définie"

**spookyz** · 22/12/2013, 16h01

Je te donne un fichier qui fonctionne chez moi

**Marc-L** · 22/12/2013, 13h41

Bonjour,

sans présentation claire & exhaustive …

Réalisable avec un classeur .xls de liens en pièce jointe
mais sans savoir que faire de la date récupérée
ni s'il faut la conserver au format anglo-saxon ou la convertir au format européen, etc …

**Marc-L** · 22/12/2013, 16h42

Envoyé par Marc-L

[…]

mais sans savoir que faire de la date récupérée

Il y a aussi des cellules en bleu souligné mais sans lien hypertexte dans le fichier joint;
cela ne pose pas de problème, juste qu'il n'y aura pas de date associée …

**spookyz** · 22/12/2013, 16h49

Il faut changer la ligne 9

Code :

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

navurl = Cells(i, 1)

par

Code :

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

navurl = Cells(i, 1).Hyperlinks(1).Address

**Marc-L** · 22/12/2013, 16h58

Mon approche est quelque peu différente, tant sur la récupération des liens que sur les dates,
certainement plus rapide mais je vais manquer de temps, à suivre plus tard dans la soirée ou demain …

**spookyz** · 22/12/2013, 17h07

un petit bonus
ce code inscrit dans la colonne 5 la véritable adresse du lien

Code :

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

1
2
3
4
5
6
7
8
Sub lien()
derli = Cells(65000, 1).End(xlUp).Row
   On Error Resume Next
    For i = 1 To derli
    navurl = Cells(i, 1).Hyperlinks(1).Address
    Cells(i, 5) = navurl
    Next i
End Sub

**parisdauphine** · 22/12/2013, 17h10

Envoyé par spookyz

Il faut changer la ligne 9 navurl = Cells(i, 1)

par

navurl = Cells(i, 1).Hyperlinks(1).Address

Merciiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii bcp

) ca marche

Envoyé par Marc-L

Mon approche est quelque peu différente, tant sur la récupération des liens que sur les dates,
certainement plus rapide mais je vais manquer de temps, à suivre plus tard dans la soirée ou demain …

Merci Bcp, on a trouvé la solution

**parisdauphine** · 23/12/2013, 23h56

Bonsoir,
je viens de tester le prog et ça marche super bien

Merci Bcp et comme a dit Spookyz "CHAPEAU L'ARTISTE". C'est rapide, ça ne bloque pas et ca saute les liens qui ne s'ouvrent pas !! Merci, vous m'avez rendu un grand service

MERCIIIIIIIIIIIIIII

))

Merci Bcp

oui, chapeau bas, ça fonctionne super bien

Merci pour votre aide à tous les deux !!
Pour la fortune, je pense qu'il faudra attendre un peu, ca sera pas pour tt de suite

Envoyé par Marc-L

Il y a aussi des cellules en bleu souligné mais sans lien hypertexte dans le fichier joint;
cela ne pose pas de problème, juste qu'il n'y aura pas de date associée …

oui, j'ai constaté ça, et effectivement ça laisse des cases vides sans dates

**patricktoulon** · 29/12/2013, 18h16

bonjour a tous
meme si le sujet est resolu ,je vous propose une autre aproche

en considerant que les liens sont dans la colonne 1 et les dates doivent se retrouver en face en colonne 2 (a adapter )

voila une petite fonction sur mesure

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
 
Option Explicit
Dim Destination As String  'variable pour le chemin complet du fichier de destination
Dim l_URL As String        ' variable pour le lien de la page html
Dim Lapage_en_HTML         'variable pour l'object "Microsoft.XMLHTTP"( l'object XML)
Dim cel As Range
Public Function GetCodeSource(sURL, Optional au_format_text As Boolean = "false")
    Set Lapage_en_HTML = CreateObject("Microsoft.XMLHTTP")    'instancie l'object
    Lapage_en_HTML.Open "GET", sURL    'ouvre l'url dans l'object
    Lapage_en_HTML.Send
    Do: DoEvents: Loop While Lapage_en_HTML.ReadyState <> 4    'attendre que la page soit chargée
      'exemple de code source End of placement</td><td>03/31/2011
     If InStr(Lapage_en_HTML.ResponseText, "End of placement") Then
     GetCodeSource = Split(Split(Lapage_en_HTML.ResponseText, "End of placement</td><td>")(1), "<")(0)
     Else
     GetCodeSource = "pas de date"
     End If
End Function
 
 
 
Sub recuperation_des_date()
For Each cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
cel.Offset(0, 1) = GetCodeSource(cel)
Next
End Sub

si ca peut servir

Au plaisir

**Marc-L** · 29/12/2013, 18h33

Salut Patrick !

Je préfère éviter le pilotage d'IE surtout dans ce cas car le site rame pas mal et comme il y a plus de 9 500 liens,
cela prendrait une bonne dizaine d'heure, Excel ou l'OS sera planté bien avant !

Au fait les liens sont en hyperliens dans les cellules, pas dans leurs valeurs …

**parisdauphine** · 01/01/2014, 15h09

Bonne et Heureuse Année

Merci Bcp Patrick

Envoyé par patricktoulon

bonjour a tous
meme si le sujet est resolu ,je vous propose une autre aproche

en considerant que les liens sont dans la colonne 1 et les dates doivent se retrouver en face en colonne 2 (a adapter )

voila une petite fonction sur mesure

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
 
Option Explicit
Dim Destination As String  'variable pour le chemin complet du fichier de destination
Dim l_URL As String        ' variable pour le lien de la page html
Dim Lapage_en_HTML         'variable pour l'object "Microsoft.XMLHTTP"( l'object XML)
Dim cel As Range
Public Function GetCodeSource(sURL, Optional au_format_text As Boolean = "false")
    Set Lapage_en_HTML = CreateObject("Microsoft.XMLHTTP")    'instancie l'object
    Lapage_en_HTML.Open "GET", sURL    'ouvre l'url dans l'object
    Lapage_en_HTML.Send
    Do: DoEvents: Loop While Lapage_en_HTML.ReadyState <> 4    'attendre que la page soit chargée
      'exemple de code source End of placement</td><td>03/31/2011
     If InStr(Lapage_en_HTML.ResponseText, "End of placement") Then
     GetCodeSource = Split(Split(Lapage_en_HTML.ResponseText, "End of placement</td><td>")(1), "<")(0)
     Else
     GetCodeSource = "pas de date"
     End If
End Function
 
 
 
Sub recuperation_des_date()
For Each cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
cel.Offset(0, 1) = GetCodeSource(cel)
Next
End Sub

si ca peut servir

Au plaisir

**spookyz** · 23/12/2013, 10h07

Bonjour à tous,
ça valait vraiment le coup d'attendre l'approche de Marc-L
chapeau l'artiste !

parisdauphine si tu fais fortune avec la bourse n'oublie pas d’être très généreux
avec cet excellent site "Developpez.com"

pense a mettre ton post en RESOLU

**Marc-L** · 23/12/2013, 11h50

Envoyé par spookyz

ça valait vraiment le coup d'attendre l'approche de Marc-L, chapeau l'artiste !

Après la version en Late Binding (voir Early ou Late Binding), voici la version censée être plus efficace en Early Binding :

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
'   Menu Outils, Références :  cocher Microsoft XML, v3.0
 
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
 
 
Sub Demo()
    Dim Hlk As Hyperlink, oXhttp As New MSXML2.XMLHTTP
 
    With Feuil1
        If WebOK(.Hyperlinks(1).Address) = False Then Beep: Exit Sub
        ReDim DT(1 To .UsedRange.Rows.Count, 1 To 1)
 
        For Each Hlk In .Hyperlinks
            With oXhttp
                .Open "POST", Hlk.Address, False
                .Send
 
                If .Status = 200 Then
                    T$ = .responseText
                    P& = InStr(T, "End of placement</td><td>")
 
                    If P Then
                        T = Mid$(T, P + 25, 10)
                        If IsDate(T) Then DT(Hlk.Parent.Row, 1) = T
                    End If
                End If
            End With
 
            DoEvents
        Next
                      Set oXhttp = Nothing
        .[E1].Resize(UBound(DT)) = DT
        Beep
    End With
End Sub

_______________

____________________________________

______________________________

Merci de cliquer sur

pour chaque message ayant aidé puis sur

pour clore cette discussion …

__________________________________________________________________________________________
La connaissance, c'est comme la confiture, moins on en a plus on l'étale !

**parisdauphine** · 26/12/2013, 00h58

Bonsoir à tous,
Joyeuses Fêtes.
J'ai essayé le code en question, ça marchait très bien le 1er jour, le 2ème jour ça ne marchait plus, à chaque fois Excel se bloque ("Ne répond pas"), ça affiche parfois "Fichier introuvable"....
Est ce que vous avez une idée de quoi vient le problème? J'ai peut être fait une mauvaise manipulation de qque chose?

Merci d'avance

**Marc-L** · 26/12/2013, 12h21

Cela arrive quand les procédures sont trop longues, j'ai pourtant placé la fonction DoEvents …

Si c'est le code en Early Binding, tenter de désélectionner la référence et choisir la version 6 (ou supérieure);
sinon tenter en Late Binding mais je n'y crois guère …

Il faudrait alors songer par travailler par petits lots, du genre sélectionner des cellules
puis exécuter une procédure traitant uniquement les liens de ces cellules si la date n'est pas renseignée …
Ou encore au déclenchement du lien, cellule par cellule …

Récupérer des données Internet [XL-2010]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager