Automatiser la recherche d'information sur boursorama

Bonjour

Je travaille sur comment automatiser la recherche d'informations sur le site boursorama mais ma Macro ne s'execute pas totalement.

Quelqu'un pourrait-il jeter un coup d'oeil svp ?

merci

Bonjour,

Le code fonctionne très bien ... la colonne B n'étant pas renseignée, le calcul s'arrête à la dernière valeur !!

k = WS.Cells(Rows.Count, [REF].Column).End(xlUp).Row

C'est un de mes codes "anciens" qu'il conviendrait peut-être de rendre plus "clair"

Merci pour ton aide j'ai reussi a charger certains cours en renseignant les differents liens

Toutefois ca ne renseigne pas tous les cours ourtant tous les liens sont renseigné. Comment faire pour que tous les cours soient chargés ?

Et aussi stp tu pourrais laisser quelques commentaires vite fait dans ton code.

Il est simple mais je comprends a peine les fonctions utilisés et a quoi elles servent.

Merci d'avance pour ton aide.

Voila le fichier ci-joint

henri27 a écrit :

Toutefois ca ne renseigne pas tous les cours ourtant tous les liens sont renseigné. Comment faire pour que tous les cours soient chargés ?

Pour éviter cela, j'ai changé le programme.

Explications sur le code un peu simplifié :

Sub MajCotations()
Dim i%, k%, URL$, COT

' k est la dernière ligne renseignée de la colonne 3
k = Cells(Rows.Count, 3).End(xlUp).Row
' on efface les données colonne 4  la ligne 2 à k
Range(Cells(2, 4), Cells(k, 4)).Clear

On Error Resume Next
For i = 2 To k
    ' DoEvents permet de "passer la main" au système pour qu'il exécute ses tâches
    DoEvents
    On Error Resume Next ' si pas de réponse (ou erreur) on poursuit le code quand même pour le prochain cours
    Set Hobj = CreateObject("MSXML2.XMLHTTP") ' création de l'objet interrogation internet
    With Hobj
        .Open "GET", Cells(i, 3).Value, False
        .Send
        ' Le code de statut de réponse HTTP 200 OK indique la réussite d'une requête
        If .Status = 200 Then
            ' double split = découpage en tableau indices 0, 1, 2 etc.
            ' premier split selon "data-ist-last>" ... on prend le second terme du tableau donc indice 1
            ' second split selon "</span>" ... on prend le premier terme du tableau donc indice 0
            Cells(i, 4).Value = Val(Split(Split(.responsetext, "data-ist-last>")(1), "</span>")(0))
       End If
    End With

Next

End Sub

Merci c'est parfait tout fonctionne a merveille

Merci

Bonjour

je reviens sur le code en effet il m'a bcp aidé.

Toute fois j'aimerai savoir s'il est possible d'integrer une caractéristique qui me permet de recuperer les cours a une date donné et bien sur de les conserver dans une feuille .

Le code actuel ne charge que les cours en temps reel

Merci d'avance.je parle du dernier fichier envoyé

C'est un peu compliqué de tout faire dans un même fichier qui va être tellement complexe qu'il ne sera plus maintenable.

Le site dispose d'un historique, je te propose de charger le tableau, reste ensuite d ton côté à en faire une sauvegarde ou une compilation.

Sub Maj()
Dim URL$, obj As New DataObject

avant = "<table class=""c-table c-table--generic"" data-table-sorter>"

For i = 1 To Sheets("URL").Range("C" & Rows.Count).End(xlUp).Row
    DoEvents
    URL = Sheets("URL").Range("C" & i)
    On Error Resume Next
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .Send
        If .Status = 200 Then

                txt = avant & Split(Split(.responseText, avant)(1), "</table>")(0) & "</table>"
                obj.SetText txt
                obj.PutInClipboard
                ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Paste
                ActiveSheet.Name = Sheets("URL").Range("A" & i)

        End If
    End With
Next
MsgBox "Fin !"
End Sub

Au-delà de cette réponse rapide, je vais regarder comment répercuter les données dans une base.

Dans le tableau, quelle est la donné qu'il faut sauvegarder ?

avec historique

Sub Maj()
Dim URL$, obj As New DataObject, sh As Worksheet

' suppression anciennes feuilles
Application.DisplayAlerts = False
For Each sh In Worksheets
    If Left(sh.Name, 1) <> "_" Then sh.Delete
Next
Application.DisplayAlerts = True

avant = "<table class=""c-table c-table--generic"" data-table-sorter>"

For i = 1 To Sheets("_URL").Range("C" & Rows.Count).End(xlUp).Row
    DoEvents
    URL = Sheets("_URL").Range("C" & i)
    On Error Resume Next
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .Send
        If .Status = 200 Then

            txt = avant & Split(Split(.responseText, avant)(1), "</table>")(0) & "</table>"
            txt = Replace(txt, "u-text-uppercase"">", "u-text-uppercase"">'") ' préservation de la date FR
            obj.SetText txt
            obj.PutInClipboard
            ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Paste
            ActiveSheet.Name = Sheets("_URL").Range("A" & i)

        End If
    End With
Next

With Sheets("_data")
    For Each sh In Worksheets
        If Left(sh.Name, 1) <> "_" Then
            ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
            For i = 2 To sh.Cells(1, Columns.Count).End(xlToLeft).Column
                .Cells(ligne, 1) = sh.Name
                .Cells(ligne, 2) = DateSerial(Year(Now), Right(sh.Cells(1, i), 2), Mid(sh.Cells(1, i), 2, 2))
                If .Cells(ligne, 2) > Now Then .Cells(ligne, 2) = DateSerial(Year(Now) - 1, Right(sh.Cells(1, i), 2), Mid(sh.Cells(1, i), 2, 2))
                .Cells(ligne, 3) = Replace(sh.Cells(2, i), ".", ",") * 1
                ligne = ligne + 1
            Next i
        End If
    Next
    .Range("Tableau1[#Tout]").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End With

Sheets("_histo").Select
ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotCache.Refresh

End Sub

Bonjour

Merci pour le code.

Concernant les resultats est ce que je peux pas avoir les cours historiques genre sur un mois (1) et aussi aux niveau des variations je pense que ca ne retrouve pas ce champ sur le site(2). Au pire je peux automatiser ce calcul des variations de cours ?

Et aussi pourrais tu ajouter quelques commentaires sur le code ca me permettrait aussi d'apprendre et de mieux le comprendre.

Merci d'avance

henri27 a écrit :

Concernant les resultats est ce que je peux pas avoir les cours historiques genre sur un mois (1) et aussi aux niveau des variations je pense que ca ne retrouve pas ce champ sur le site(2). Au pire je peux automatiser ce calcul des variations de cours ?

peux-tu me dire où je peux trouver ces valeurs sur un mois ? sinon par interrogations régulières la base de données va se compléter au fur et a mesure

je vais ajouter les variations

henri27 a écrit :

Et aussi pourrais tu ajouter quelques commentaires sur le code ca me permettrait aussi d'apprendre et de mieux le comprendre.

Sub Maj()
Dim URL$, obj As New DataObject, sh As Worksheet

' suppression anciennes feuilles
' je désactive les alertes, sinon excel me demandra si je suis sûr d vouloir supprimer la feuille
Application.DisplayAlerts = False
' pour toutes les feuilles
For Each sh In Worksheets
    ' si leur nom ne commence pas par un underscore que je réserve aux feuilles permanentes alors je les supprime
    If Left(sh.Name, 1) <> "_" Then sh.Delete
Next
Application.DisplayAlerts = True

' ce terme me permet de sélectionner le bon tablau historique du cours de la page
avant = "<table class=""c-table c-table--generic"" data-table-sorter>"

' i sera le numéro de ligne, depuis 1 jusqu'à la dernière ligne rensignée de la colonne C
' on part en fait de la dernière cellule de C avec rows.count qui signifie le nombre total de lignes pour excel
' et on remonte par end(xlup) jusqu'à celle rensignée dont on prend le numéro de ligne ou row
For i = 1 To Sheets("_URL").Range("C" & Rows.Count).End(xlUp).Row
    ' instructions classiques dans le cas d'un interrogation web
    DoEvents
    URL = Sheets("_URL").Range("C" & i)
    On Error Resume Next
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .Send
        ' Le code de statut de réponse HTTP 200 OK indique la réussite d'une requête
        If .Status = 200 Then

            ' je découpe la réponse pour en extraire le tableau
            ' première découpe avec le critère défini ci-dssus ... j'en prend la seconde partie (indice 1)
            ' duxième découpe avec </table> dont je prends la première partie (indoce 0)
            ' et je rajoute les balises <table... et </table>
            txt = avant & Split(Split(.responseText, avant)(1), "</table>")(0) & "</table>"
            ' j'ajoute une apostrophe devant les dates pour les préserver et éviter qu'excel n'en fasse ce qu'il veut
            txt = Replace(txt, "u-text-uppercase"">", "u-text-uppercase"">'") ' préservation de la date FR
            ' je colle cela dans le press-papier
            obj.SetText txt
            obj.PutInClipboard
            ' j'ajoute une feuille
            ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
            ' je colle le tablau dans la feuille (excel sait reconnaître qu'il s'agit d'un tableau d données html)
            ActiveSheet.Paste
            ' je donne le nom de la valeur à la feuille
            ActiveSheet.Name = Sheets("_URL").Range("A" & i)

        End If
    End With
Next

' maintenant je vais contruire ou compléter ma base de données en allant chercher les informations dans chaqu feuille ne commençant pas par underscore
With Sheets("_data")
    For Each sh In Worksheets
        If Left(sh.Name, 1) <> "_" Then
            ' dernière ligne rensignée plus une (donc première ligne vierge)
            ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
            ' je balaye toutes les colonnes du tableau aspiré
            For i = 2 To sh.Cells(1, Columns.Count).End(xlToLeft).Column
                ' nom d la valeur
                .Cells(ligne, 1) = sh.Name
                ' date de cotation avec invention de l'année qui n'est pas mentionnée sur le site !
                .Cells(ligne, 2) = DateSerial(Year(Now), Right(sh.Cells(1, i), 2), Mid(sh.Cells(1, i), 2, 2))
                If .Cells(ligne, 2) > Now Then .Cells(ligne, 2) = DateSerial(Year(Now) - 1, Right(sh.Cells(1, i), 2), Mid(sh.Cells(1, i), 2, 2))
                ' cotation en remplaçant le point par virgule
                .Cells(ligne, 3) = Replace(sh.Cells(2, i), ".", ",") * 1
                ' ligne suivante
                ligne = ligne + 1
            Next i
        End If
    Next
    ' suppression des doublons si une valeur a déjà été chargée pour le mêm jour
    .Range("Tableau1[#Tout]").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End With

' mise à jour du TCD
Sheets("_histo").Select
ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotCache.Refresh

End Sub

Avec la variation :

            For i = 2 To sh.Cells(1, Columns.Count).End(xlToLeft).Column
                ' valeur boursière
                .Cells(ligne, 1) = sh.Name
                ' date
                .Cells(ligne, 2) = DateSerial(Year(Now), Right(sh.Cells(1, i), 2), Mid(sh.Cells(1, i), 2, 2))
                If .Cells(ligne, 2) > Now Then .Cells(ligne, 2) = DateSerial(Year(Now) - 1, Right(sh.Cells(1, i), 2), Mid(sh.Cells(1, i), 2, 2))
                ' cotation
                .Cells(ligne, 3) = Replace(sh.Cells(2, i), ".", ",") * 1
                ' variation
                .Cells(ligne, 4) = Replace(Replace(sh.Cells(3, i), ".", ","), "%", "") / 100
                ligne = ligne + 1
            Next i

Nota : je me suis aperçu que le tableau historique pouvait évoluer entre deux interrogations !!

Bonjour

je sais pas chez moi j'ai toujours les lignes Variations avec la valeur #Champ, donc pas de valeur.

D'un autre coté dans le site de boursorama tu as un onglet "historique" qui te recense les differents historiques des cours des titres.

henri27 a écrit :

j'ai toujours les lignes Variations avec la valeur #Champ, donc pas de valeur.

aurais-tu une capture d'écran ?

henri27 a écrit :

D'un autre coté dans le site de boursorama tu as un onglet "historique" qui te recense les differents historiques des cours des titres.

henri27 a écrit :

dans le site de boursorama tu as un onglet "historique" qui te recense les differents historiques des cours des titres.

Il ne sont pas toujours directement accessibles ! et cela varie de temps en temps, je n'ai donc pas réussi à maîtriser cela d efaçon fiable (alors que c'est bien cette URL qui est celle de l'historique).

C'est la première fois que je rencontre ce fonctionnement ! Boursorama doit ajouter un cookie qui indique que l'internaute est bien passé par la page d'accueil.

Essaie avec PowerQuery peut-être

je re-poste le dernier fichier car il vaut mieux utiliser le max que la somme (il y a parfois des valeurs différentes en fonction du moment de la journée où on interroge)

bref ce n'est pas non plus très fiable

@henri27 :

permet de charger des historiques

Bonjour

En effet je recupere bien les cours de bourses tout est parfait.

je viens une fois de plus avec mon fichier. Cette fois ci j'ai creer une feuille "_Resume" qui recense en differents trableaux les principaux indices dont jai besoin: Col 1 = nom de lindice

col 2 = cours

col 3 = variation

en effet j'aimerai avoir une macro qui va chercher les informations dans les differentes feuilles correspondant aux indices et les colle dans la feuille "_Resume" de telle sorte que les données soit actualisées chaque fois qu'on charge les données depuis les url

exemple: dans la feuille "_Resume", pour l'indice CAC40, la macro va chercher le dernier cours et la variation dans la feuille "CAC40" et vient la coller dans Resume dans la cellule correspondante

Ci joint le document

merci