(不定期更新)使用VBA解決 excel web 查詢無法匯入、匯入太慢的股市資料

peter624 wrote:
(1)在308樓將k線圖(走勢圖)，製作一個整合的網頁，大概知道如何撰寫，
但是要將其他的圖也併入，如https://tw.stock.yahoo.com/quote/2379/revenue
年季月的營收圖也整合成一個網頁，卻找不到對應的js檔。
(2)使用clipboard的方式下載https://tw.stock.yahoo.com/quote/2379/revenue，如何設定參數"月季年"，
抓取不同的table，有參考你寫的Get_Yahoo_dividend_clipboard，只是不會抓各別的"月季年"營收。
(2)https://tw.stock.yahoo.com/quote/2379/revenue可以使用jason的方式下載嗎?可以的話不曉得如何撰寫。

'這裡是用“年營收”，當下載範例
'月、季，網址、排版、callbyname，請自行做適當的修改
'prid參數，因網頁原始碼中有標示test，測試後發現不用也行

'年營收


'季



'月



Sub Get_Yahoo_revenue_Json()

    Dim URL As String, Url_a As String, GetXml As Object, Jsondata As Object, DecodeJson, Stock As String, prid As String
    
    'Stock = "2412"   'test
    'Stock = "2002"    'test
    'Stock = "2330"    'test
    Stock = "2379"    'test
    
    ttt = Timer
    
     
    Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
    Set Jsondata = CreateObject("HtmlFile")
    
    
    


    
    URL = "https://tw.stock.yahoo.com/quote/" & Stock & "/revenue"


    With GetXml
    
        '===================================================================
        'prid參數，暫時用不到
        '.Open "GET", URL, False
        '.setRequestHeader "Cache-Control", "no-cache"
        '.setRequestHeader "Pragma", "no-cache"
        '.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        '.send
            
        'prid = "prid=" & Left(Split(.responsetext, """prid"":""")(1), 13)
        '===================================================================
            
            

(點我看大圖，因語法關係，使用圖片代替，或到文未下載網址txt檔)



            
            
        .Open "GET", Url_a, False
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "Referer", URL
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
            
             
        Set DecodeJson = CallByName(CallByName(CallByName(CallByName(Jsondata.JsonParse(.responsetext), "data", VbGet), "data", VbGet), "result", VbGet), "revenues", VbGet)
               
        With Sheets("工作表1")
            .Cells.Clear

'如果下載月、季，以下程式碼需做適當的修改
            .Range("a1:d1") = Array("年度", "當年營收", "去年營收", "年增率%")
                
            For i = 0 To CallByName(DecodeJson, "length", VbGet) - 1
                .Cells(i + 2, 1) = CallByName(CallByName(DecodeJson, i, VbGet), "date", VbGet)
                .Cells(i + 2, 2) = "'" & CallByName(CallByName(DecodeJson, i, VbGet), "revenue", VbGet)
                .Cells(i + 2, 3) = "'" & CallByName(CallByName(CallByName(DecodeJson, i, VbGet), "lastYear", VbGet), "revenue", VbGet)
                .Cells(i + 2, 4) = CallByName(CallByName(DecodeJson, i, VbGet), "revenueYoY", VbGet) & "%"
            Next i
                
            .Cells.Columns.AutoFit
        End With
            
        Application.ScreenUpdating = True
            
    End With
    
    
    MsgBox Stock & vbNewLine & Timer - ttt & "s", vbOKOnly, "report"  'debug
        
    Set GetXml = Nothing
    Set Jsondata = Nothing
    Set DecodeJson = Nothing
    
End Sub

g80860 wrote:
https://mis.taifex.com.tw/futures/VolatilityQuotes/

Sub Get_taifex_Json()

    Dim URL As String, GetXml As Object, Jsondata As Object, DecodeJson
    Set GetXml = CreateObject("msxml2.xmlhttp")
    Set Jsondata = CreateObject("HtmlFile")
    
    



    
    URL = "https://mis.taifex.com.tw/futures/api/getChartDataTick"


    With GetXml
    
        .Open "POST", URL, False
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "Content-type", "application/json"
        .setRequestHeader "Accept", "application/json"
        .setRequestHeader "Referer", "https://mis.taifex.com.tw/futures/VolatilityQuotes/"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
       
        .send ("{""SymbolID"":""TAIWANVIX""}")
        
        'debug
        Debug.Print .responsetext
             
        Set DecodeJson = CallByName(Jsondata.JsonParse(.responsetext), "RtData", VbGet)
              
        'debug
        MsgBox CallByName(DecodeJson, "DispCName", VbGet) & vbNewLine & _
               CallByName(CallByName(DecodeJson, "Quote", VbGet), "CLastPrice", VbGet) & vbNewLine & _
               CallByName(CallByName(DecodeJson, "Quote", VbGet), "COpenPrice", VbGet) & vbNewLine & _
               CallByName(CallByName(DecodeJson, "Quote", VbGet), "CHighPrice", VbGet) & vbNewLine & _
               CallByName(CallByName(DecodeJson, "Quote", VbGet), "CLowPrice", VbGet) & vbNewLine & _
               CallByName(CallByName(DecodeJson, "Quote", VbGet), "CRefPrice", VbGet) & vbNewLine & _
               CallByName(CallByName(DecodeJson, "Quote", VbGet), "CDate", VbGet), vbOKOnly, "debug"
              
    End With
    
        
    Set GetXml = Nothing
    Set Jsondata = Nothing
    Set DecodeJson = Nothing
    
End Sub

snare wrote:
一、yahoo營收圖...(恕刪)

alfidpan wrote:
還有什麼是索引？以敝人這個例子"blocks"是索引嗎？還是是字串？
(恕刪)

alfidpan wrote:
再加問一個問題，JSON要如何找字串，而不是只找索引呢
(恕刪)

alfidpan wrote:

再追加問另一個問題，如果利用VBA-JSON JsonConverter 是否可以匯入第二層以下，甚至第三層以下的資料呢？
(恕刪)

alfidpan wrote:
以上是可以匯入第一層內的資料，但想要進入第二層 7，就是不知要如何寫呢？
最終是想要匯入7內"sections"中0、1、2的資料。
(恕刪)

Sub Get_barrons_Json()

    Dim URL As String, GetXml As Object, Jsondata As Object, DecodeJson
    Set GetXml = CreateObject("msxml2.xmlhttp")
    Set Jsondata = CreateObject("HtmlFile")
    
    
 


    
    URL = "https://www.barrons.com/market-data/api/proxy?https://quote-barrons.millstone.mktw.dowjones.io/api/quote/financials?chartingSymbol=stock///ko&urlFragment=cash-flow/annual"


    With GetXml
    
        .Open "GET", URL, False
        .send
        
        '第0層
        
        '第1層
        Set DecodeJson = CallByName(Jsondata.JsonParse(.responsetext), "blocks", VbGet)
        
        Dim json, json1, json2, json3, i As Integer, j As Integer, k As Integer
        On Error Resume Next
        
        '第2層(0~6跳過，請自行補上)
        Set json = CallByName(CallByName(DecodeJson, "7", VbGet), "sections", VbGet)
        
        For i = 0 To CallByName(json, "length", VbGet) - 1
            
            '第3層
            Set json1 = CallByName(CallByName(json, i, VbGet), "items", VbGet)
            
            For j = 0 To CallByName(json1, "length", VbGet) - 1
            
                '第4層
                Set json2 = CallByName(json1, j, VbGet)
                Debug.Print CallByName(json2, "displayName", VbGet)
                
                '第5層
                Set json3 = CallByName(json2, "values", VbGet)
                
                                
                For k = 0 To CallByName(json3, "length", VbGet) - 1
                
                    '第6層
                    Debug.Print CallByName(CallByName(json3, k, VbGet), "formatted", VbGet), CallByName(CallByName(json3, k, VbGet), "value", VbGet)
                Next k
                
                Debug.Print vbNewLine
                
            Next j
        Next i
          
    End With
    
        
    Set GetXml = Nothing
    Set Jsondata = Nothing
    Set DecodeJson = Nothing
    Set json = Nothing
    Set json1 = Nothing
    Set json2 = Nothing
    Set json3 = Nothing
    
End Sub

peter624 wrote:
其中 temp=110/11,[object Object]變數抓不到後面的id值

'……其它程式碼，請自行補上

Dim DOC_ID As String, fileName As String
For i = 0 To CallByName(temp, "length", VbGet) - 1

    DoEvents
    
    DOC_ID = CallByName(CallByName(CallByName(temp, i, VbGet), "1", VbGet), "id", VbGet)
    fileName = CallByName(CallByName(CallByName(temp, i, VbGet), "1", VbGet), "fileName", VbGet)
    
    URLDownloadToFile 0, Url_b & DOC_ID, Target & fileName, 0, 0

Next i

rainbowsperm wrote:
https://goodinfo.tw/StockInfo/StockList.asp?RPT_TIME=&MARKET_CAT=熱門排行&INDUSTRY_CAT=投信累計買超金額 – 當日@@投信累計買超@@投信買超金額 – 當日

現在用之前的方法如下 已經無法取得資料

Sub get_goodinfo_test()

    Dim Xmlhttp As Object, HTMLsourcecode As Object, Table
    Set HTMLsourcecode = CreateObject("htmlfile")
    Set Xmlhttp = CreateObject("msxml2.xmlhttp")

    Application.ScreenUpdating = False

    Cells.Clear

    Url = "https://goodinfo.tw/StockInfo/StockList.asp?RPT_TIME=&MARKET_CAT=%E7%86%B1%E9%96%80%E6%8E%92%E8%A1%8C&INDUSTRY_CAT=%E6%8A%95%E4%BF%A1%E7%B4%AF%E8%A8%88%E8%B2%B7%E8%B6%85%E9%87%91%E9%A1%8D%20%E2%80%93%20%E7%95%B6%E6%97%A5@@%E6%8A%95%E4%BF%A1%E7%B4%AF%E8%A8%88%E8%B2%B7%E8%B6%85@@%E6%8A%95%E4%BF%A1%E8%B2%B7%E8%B6%85%E9%87%91%E9%A1%8D%20%E2%80%93%20%E7%95%B6%E6%97%A5"

    With Xmlhttp
        .Open "GET", Url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send
        HTMLsourcecode.body.innerhtml = .responsetext 

        If InStr(HTMLsourcecode.body.innerhtml, "瀏覽量異常") > 0 Then
            MsgBox HTMLsourcecode.body.innertext
            Exit Sub
        End If


        'Set Table = HTMLsourcecode.getElementById("divStockList") 'txtStockListData
        'Call Clipboard_Past("temp", Table)
            

        Set Table = HTMLsourcecode.getElementById("tblStockList").Rows
        Call Cell_by_Cell("temp", Table)


        Sheets("temp").Cells(1, 1).Select
        Sheets("temp").Cells.EntireColumn.AutoFit


    End With

    Application.ScreenUpdating = True

    Set HTMLsourcecode = Nothing
    Set Xmlhttp = Nothing
    Set Table = Nothing

End Sub



Sub Cell_by_Cell(sheet_name As String, Table)
    
    Dim i As Integer, j As Integer, lastrow As Integer
    
    lastrow = Sheets(sheet_name).Range("A1").CurrentRegion.Rows.Count
    
    For i = 0 To Table.Length - 1
        For j = 0 To Table(i).Cells.Length - 1
            Sheets(sheet_name).Cells(i + 1 + IIf(lastrow > 1, lastrow, 0), j + 1) = IIf(j = 1, "'", "") & Table(i).Cells(j).innertext
        Next j
    Next i
   

End Sub



Sub Clipboard_Past(sheet_name As String, Table)
    
    Dim Clipboard As Object, lastrow As Integer
    Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
    Clipboard.settext Table.innerhtml
    Clipboard.putinclipboard
    
    lastrow = Sheets(sheet_name).Range("A1").CurrentRegion.Rows.Count
    Sheets(sheet_name).Cells(lastrow + IIf(lastrow > 1, 1, 0), 1).Select
    Sheets(sheet_name).PasteSpecial NoHTMLFormatting:=True
      
    Set Clipboard = Nothing
    
End Sub

snare wrote:
2021-11-29 23:38