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

**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 …

**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

**parisdauphine** · 22/12/2013, 16h38

Merci Merci ça marche super bien

et en plus les dates sont dans le bon sens (DD/MM/YYYY) Merciiiiiiiiii

encore une dernière petite chose stp, ça ne fonctionne plus quand je mets MES liens dans ton fichier, voici mon fichier avec les liens

**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

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

Il serait intéressant de laisser Marc_L proposer
une autre solution plus performante pour toi, pour moi et pour les autres
ensuite tu pourras mettre RÉSOLU sur ton post
cordialement

**parisdauphine** · 22/12/2013, 18h52

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 MARC, ça serait bien d'avoir une autre approche

Ca marche bien, mais parfois y'a des liens qui ne s'ouvrent pas rapidement donc ça bug, on peut pas rajouter une condition, si le lien ne s'ouvre pas, il passe au suivant?

**Marc-L** · 23/12/2013, 02h48

Une adresse de cellule pour un tel lien ? De toute manière, les liens, c'est lent …

Sinon voici une autre approche (sans référence à activer), voir la procédure Demo :

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
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
 
    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 CreateObject("MSXML2.XMLHTTP")
                .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
 
        .[E1].Resize(UBound(DT)) = DT
        Beep
    End With
End Sub

J'ai allégé au maximum mes procédures habituelles pour grapiller du temps …

Les dates stockées dans une variable tableau sont inscrites en colonne en une fois à la fin de la procédure (ligne n°36);
mais en insistant sur la touche Echap, grâce à la ligne n°33, l'exécution peut être interrompue puis,
via le bouton Débogage, le processus peut être redirigé vers la ligne n°36 …

__________________________________________________________________________________________

Merci de cliquer sur

pour chaque message ayant aidé puis sur

pour clore cette discussion …

__________________________________________________________________________________________
Pour s'endormir, un mouton ne peut compter que sur lui-même …

**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

**parisdauphine** · 23/12/2013, 11h41

Merci bcp Marc, je teste ça ce soir (je n'ai pas le Pc là) et je vous tient au courant. Merci encore une fois

**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** · 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

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

Macros et VBA Excel

Discussions similaires

Partager

Partager