Discussion :

[Philippe A. Dubé]

Bonjour,

J'ai un problème avec l'import des tableaux web. Voici le code en question, dont la partie en rouge importe les états financiers de tous les titres d'un fichier.

Les données qui en résultent sont séparées au milliers par des virgules et il n'y a jamais de cents.

Comme mon excel sépare les cents au niveau des virgules, lorsque le montant est de moins d'un million (2 virgules) il comprend 439 ,000 comme étant 439.

Je pourrais contourner ce problème en multipliant par 1000 tous les montants inférieurs à un million, mais j'aimerais tout de même mieux intégrer les bonnes commandes à ma requête.

J'ai fouillé internet sans succès, alors si la réponse à ma question existe déjà, sachez que j'ai cherché ardemment.

MERCI DE VOTRE SOUTIENT,


Phil

Voici la macro :

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
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
'Technical download function
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
 'Download CSV containing historical prices from Yahoo Finance
 'and open with Microsoft Excel
 'VBA code by Joshua Radcliffe, www.joshuaradcliffe.com
  
Sub MAJ_EF()
'
' MACRO MAJ_EF
'
Dim Repertoire As String, Fichier As String
Dim Wb As Workbook
Dim Ws As Worksheet
Dim i As Integer
Dim download
Dim stocklink As String
Dim savefile As String
Dim stock As String
    
    
        Application.Volatile
    Application.DisplayAlerts = False
    
    
'Définit la Première feuille du classeur contenant cette macro
'(pour recevoir les donnée extraites dans les autres classeurs).
Set Ws = ThisWorkbook.Worksheets(1)
 
'Définit le répertoire de recherche
Repertoire = "A:\Documents\Bourse\Données par titres\"
'Spécifie la recherche pour le fichiers .xlsx
Fichier = Dir(Repertoire & "*.xlsx")
 
'Boucle sur les fichiers du répertoire
Do While Fichier <> ""
    'Vérifie que le nom du classeur est différent du classeur
    'contenant cette macro (dans le cas ou il serait placé dans le même répertoire).
    If ThisWorkbook.Name <> Fichier Then
        'Ouvre chaque classeur
        Set Wb = Workbooks.Open(Repertoire & Fichier)
        i = i + 1
        
        Application.ScreenUpdating = False
          
    stock = Sheets("Cotes").Cells(1, 1).Value
    
    Sheets("ER Annuels").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://fr-ca.finance.yahoo.com/q/is?s=" & stock & "&annual", _
        Destination:=Range("$A$1"))
        .Name = "ER ANNUELS"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
      
    Application.Goto Range("A1"), True
        
       'Enregistre & Ferme
        ActiveWorkbook.Save
                     
        Application.ScreenUpdating = True
        
    End If
    
    Fichier = Dir
    
Loop

'   Réactive les alertes d'application
'
    Application.DisplayAlerts = Tru
    

End Sub

[patricktoulon]

bonjour
pourrais tu donner un ticker pour l'exemple
et une valeur pour anual
https://fr-ca.finance.yahoo.com/q/is?s=" & stock & "&annual"

[Philippe A. Dubé]

Tu peux utiliser AAPL par exemple. Annual c'est juste pour avoir l'état des résultats annuel. Pas plus complexe, c'est la suite de l'adresse.

[patricktoulon]

bonjour


je viens d'essayer de faire une requete et il semblerait que le site l'interdise (ni get ni POST)
il te reste plus que IE
il y des script qui font que si le handle ne correspond pas tu a du charabia

les données des table sont bien la pour la plus part mais sous forme de texte donc difficilement exploitables


pour info ma requete :

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
Function colletable_dans_sheets(valeur)
'urlyfnc_tabledata1
    Dim ReQ, url
    url = "https://fr-ca.finance.yahoo.com/q/is?s=" & valeur & "&annual"
    'url = "https://fr-ca.finance.yahoo.com/q/is?s=AAPL&annual"
    Set ReQ = CreateObject("microsoft.xmlhttp")
    ReQ.Open "get", url, False
    'parametre de la requete
    ReQ.SetRequestHeader "Accept", "text/html, application/xhtml+xml, */*"
    ReQ.SetRequestHeader "Accept-Language", "fr-FR"
    ReQ.SetRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"
    ReQ.SetRequestHeader "Accept-Encoding", "gzip, deflate"
    ReQ.SetRequestHeader "Host", "fr - ca.finance.yahoo.com"
    ReQ.SetRequestHeader "DNT", "1"
    ReQ.SetRequestHeader "Connection", "Keep - Alive"
    ReQ.send
    With CreateObject("htmlfile")
.body.innerhtml = ReQ.responsetext
        If .parentWindow.clipboardData.setData("Text", .body.innerhtml) Then
            Application.ScreenUpdating = False
            With Sheets(1)
                .Activate
                .Cells.Clear
                Cells(1, 1).Select
                .Paste
            End With
        End If
    End With
End Function
 
Sub test()
' exemple de 'https://fr-ca.finance.yahoo.com/q/is?s=AAPL&annual
    colletable_dans_sheets "AAPL"
End Sub

[patricktoulon]

voila j'ai fait peter le script de protection

j'importe tout sur le sheets

regarde si tu trouve ton bonneur dans toutes ces données

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
Function colletable_dans_sheets(valeur)
'urlyfnc_tabledata1
    Dim ReQ, url
    url = "https://fr-ca.finance.yahoo.com/q/is?s=" & valeur & "&annual"
    'url = "https://fr-ca.finance.yahoo.com/q/is?s=AAPL&annual"
    Set ReQ = CreateObject("microsoft.xmlhttp")
    ReQ.Open "get", url, False
    'parametre de la requete
    ReQ.SetRequestHeader "Accept", "text/html, application/xhtml+xml, */*"
    ReQ.SetRequestHeader "Accept-Language", "fr-FR"
    ReQ.SetRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"
    ReQ.SetRequestHeader "Accept-Encoding", "gzip, deflate"
    ReQ.SetRequestHeader "Host", "fr - ca.finance.yahoo.com"
    ReQ.SetRequestHeader "DNT", "1"
    ReQ.SetRequestHeader "Connection", "Keep - Alive"
    ReQ.send
    With CreateObject("htmlfile")
'on fait peter le bloqueur  ici balise script (3)
lscript = Split(ReQ.responsetext, "<script")
code = Replace(ReQ.responsetext, Split(lscript(3), "/script>")(0), "")
.body.innerhtml = code
 
  ' ici tu peut manipuler l'object comme IE
 
        If .parentWindow.clipboardData.setData("Text", .body.innerhtml) Then
            Application.ScreenUpdating = False
            With Sheets(1)
                .Activate
                .Cells.Clear
                Cells(1, 1).Select
                .Paste
            End With
        End If
    End With
End Function
 
Sub test()
' exemple de 'https://fr-ca.finance.yahoo.com/q/is?s=AAPL&annual
    colletable_dans_sheets "AAPL"
End Sub