Boursorama telechargement de cours avec cours-action-boursorama-new.xlsm

Le 10/04/2022 à 14:45

J'utilise "cours-action-boursorama-new.xlsm" qui convient pour les actions simples dont l'url est du type :

www boursorama com/cours/1rPSTM

mais les url du type pour les opcvm:

boursorama com/bourse/opcvm/cours/0P0000YRTT

ou mieux du type historique:

boursorama com/cours/historique/1rPSTM

boursorama com/bourse/opcvm/cours/historique/0P0000YRTT

ne marchent pas !

Le type historique permet de dater et charger la dernière cotation et la variation depuis le dernier cours.*

Merci pour votre aide ! Help!

Le code actuel:

Sub MajCotations()
Dim i%, k%, URL$, COT
k = Cells(Rows.Count, [REF].Column).End(xlUp).Row

Range(Cells(2, [Cotation].Column), Cells(k, [Cotation].Column)).Clear

avant = """price"":"
apres = ","

On Error Resume Next
For i = 2 To k
DoEvents
ReDim COT(1 To k, 1 To 1)
COT(1, 1) = Cells(i, [Cotation].Column).Value
URL = Cells(i, [WWW].Column).Value

Application.StatusBar = "Mise à jour des cotations en cours …"
On Error Resume Next
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.Send
If .Status = 200 Then COT(i, 1) = Split(Split(.responseText, avant)(1), apres)(0)
End With
Application.StatusBar = False
Cells(i, [Cotation].Column).Value = COT(i, 1)
Next
End Sub

Le 10/04/2022 à 14:49

Bonjour,

j'ai une première solution qui devrait coller à ton soiuhait, mais il reste à voir si les paramètres conviennent à toutes les valeurs boursières car parfois le site lui-même est codé différemment

Option Explicit

Sub interroger()
Dim page As New HTMLDocument, cours As Object, i%, ladate As Object, response As String
On Error Resume Next
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
    If Range("B" & i) <> "" Then
        Range("C" & i) = ""
        Range("D" & i) = ""
        response = pageHTML(Range("B" & i))
        page.body.innerHTML = response
        Set cours = page.getElementsByClassName("c-instrument c-instrument--last")
        Range("C" & i) = Val((cours(0).innerHTML))
        Set ladate = page.getElementsByClassName("c -faceplate__real - Time")
        Range("D" & i) = Left(Split(response, "dernier cours connu au ")(1), 10)
    End If
Next
End Sub

Function pageHTML(url As String) As String
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", url, False
        .send
        pageHTML = .responseText
    End With
End Function
35boursorama-cours-historique.xlsm (18.05 Ko)
Le 10/04/2022 à 14:51

j'ai toutefois ressorti et nettoyé un ancien projet qui me parait plus performant

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

' suppression anciennes feuilles
supp

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

Application.ScreenUpdating = False

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

Application.ScreenUpdating = True

Sheets("_data").Select
With ActiveSheet.ListObjects(1)
    .DataBodyRange.Delete

    For Each sh In Worksheets
        If Left(sh.Name, 1) <> "_" Then
            For i = 2 To sh.Cells(1, Columns.Count).End(xlToLeft).Column
                ActiveSheet.ListObjects(1).ListRows.Add
                .DataBodyRange(.ListRows.Count, 1) = sh.Name
                .DataBodyRange(.ListRows.Count, 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))
                .DataBodyRange(.ListRows.Count, 3) = Replace(sh.Cells(2, i), ".", ",") * 1
                .DataBodyRange(.ListRows.Count, 4) = Replace(Replace(sh.Cells(3, i), ".", ","), "%", "") / 100
            Next i
        End If
    Next

End With
ActiveSheet.PivotTables(1).PivotCache.Refresh

supp

End Sub

Sub supp()
Application.DisplayAlerts = False
For Each sh In Worksheets
    If Left(sh.Name, 1) <> "_" Then sh.Delete
Next
Application.DisplayAlerts = True
End Sub
53interroger-historique-des-cours-boursorama-et-archiver-template.xlsm (67.69 Ko)
Le 10/04/2022 à 17:25

Les deux solutions sont presque parfaites.

Dans la première la dernière date connue n'apparait pas toujours , or elle est sur le site "historique"

Dans ta seconde et dernière feuille on a trop de lignes et je ne sais comment insérer ma liste

Mon besoin c'est un tableau avec pour chaque valeur dont j'ai l'URL Boursorama (ou mieux via le code ISIN):

  1. - Date derniere cotation connue
  2. - prix (cote)
  3. - evolution

Sinon (je crois ne pas être le seul) je ne sais comment te remercier encore pour cette aide et cette réactivité.

Le 11/04/2022 à 03:18

Je pense que la seconde solution est plus stable. Je vais regarder comment ne retenir qu'une seule valeur, la plus récente avec la date. J'avoue qu'avec Google Sheets ce serait plus simple.

Le 11/04/2022 à 07:05

J'ATTENDS CELA AVEC IMPATIENCE !

via l'historique donc:

www boursorama com/cours/historique/1rPAI

et non :

www boursorama com/cours/1rPAI

(j'ai retiré les "." dans les liens, car le forum interdit aux "novices" de mettre des liens ? !)

Juste 3 infos:

  1. date dernier cours connu(1ère sur le site boursorama dans le tableau historique)
  2. dernier cours connu
  3. variation

Merci encore !

Le 11/04/2022 à 10:54
88boursorama-cours-historique-v1.xlsm (17.95 Ko)
Option Explicit

Sub interroger()
Dim page As New HTMLDocument, response As String, url As String, i As Integer
On Error Resume Next

For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
    url = Range("B" & i)
    If Range("B" & i) <> "" Then
        Range("C" & i) = ""
        Range("D" & i) = ""
        Range("E" & i) = ""
        response = pageHTML(url)
        page.body.innerHTML = response
        Range("C" & i) = (page.getElementsByTagName("TD")(0).innerHTML)
        Range("D" & i) = Val(page.getElementsByTagName("TD")(1).innerHTML)
        Range("E" & i) = (page.getElementsByTagName("TD")(2).innerHTML)
    End If
Next

End Sub

Function pageHTML(url As String) As String
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", url, False
        .send
        pageHTML = .responseText
    End With
End Function
Le 11/04/2022 à 19:24

C'est paaaaaaaaaaaaarfait !

Un petit détail tout de même, si je cré un nouveau fichier pas de pb , si je rajoute la macro à un fichier existant il refuse et plante sur cette instruction:

Dim page As New HTMLDocument 
"erreur de compilation": "type défini par l'utilisateur non défini"
Qu'en penses tu ?
Le 11/04/2022 à 19:29

il te manque une référence à cocher

image image
Le 16/04/2022 à 09:46

au fait merci encore !

Le 16/04/2022 à 10:26

in fine ce n'est pas un problème de codage, dommage que personne n'aie pris la peine de regarder ce point

Rechercher des sujets similaires à "boursorama telechargement cours action new xlsm"