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

snare wrote:
會錯誤是因為，json沒有做成正確格式
temp = "{""QuoteDividendStore"":{""dividend"":{""data"":[" & Split(Split(.responsetext, """QuoteDividendStore"":{""dividend"":{""data"":[")(1), ",""WaferMarketTimeStore"":")(0) & "}"...(恕刪)

activer wrote:
本次股利查詢的 temp=.....的結尾僅加個"}",而您的新版的股票程式碼卻加了3個"}",這兩個的差異,不知要如何才能判斷並成正確的json格式?

snare wrote:
範例中只取出”部份json字串”，json格式被破壞，程式就無法判讀，所以需要修補字串
加幾個不一定，有時很還要補上 [ 或 ]、前、後不一定，有時前面也要補
很單純要看怎麼拆字串

Dylan67 wrote:
可以在Set Arr後進行[轉置]，
我現在的圖是錯的

Sub test()
'(程式碼中不含“舊”圖表刪除功能)    
    Dim ChtObj As ChartObject, Arr As Variant, Brr As Variant, temp() As Double, i As Integer, j As Integer
    
    Set ChtObj = ActiveSheet.ChartObjects.Add(50, 70, 300, 250)
    Arr = ActiveSheet.Range("b2:e5").Value2
 '您要問的arr不放到格子𥚃，直接轉置到brr
   Brr = Application.Transpose(Arr)
    ReDim temp(1 To UBound(Brr, 2))
    
    With ChtObj.Chart
        For i = 1 To UBound(Brr, 1)
            .SeriesCollection.NewSeries
            For j = 1 To UBound(Brr, 2)
                temp(j) = Brr(i, j)
            Next j
            .SeriesCollection(i).Values = temp
        Next i
        .ChartType = xlStockOHLC
    End With
    
End Sub

Sub Get_Yahoo_brokerTrades_Json()

    Dim URL As String, GetXml As Object, Jsondata As Object, DecodeJson, temp As String, Stock As String, buyerRankList, sellerRankList, DataTime As String

    'Stock = "2412"   'test
    'Stock = "2002"    'test
    Stock = "2330"    'test
    
    ttt = Timer
    
     URL = "https://tw.stock.yahoo.com/quote/" & Stock & "/broker-trading"
        
    Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
    Set Jsondata = CreateObject("HtmlFile")
    


        With GetXml
        
            .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
             
            temp = "{""brokerTrades"":{""data"":{""buyerRankList"":[" & Split(Split(.responsetext, """brokerTrades"":{""data"":{""buyerRankList"":[")(1), ",""totalDifferenceVolK"":")(0) & "}}}"
            DataTime = Split(Split(.responsetext, "datatime=""")(1), """>")(0)
            
            Set DecodeJson = CallByName(CallByName(Jsondata.JsonParse(temp), "brokerTrades", VbGet), "data", VbGet)
            Set buyerRankList = CallByName(DecodeJson, "buyerRankList", VbGet)
            Set sellerRankList = CallByName(DecodeJson, "sellerRankList", VbGet)
                
            With Sheets("工作表1")
                .Cells.Clear
                .Range("a1:h1") = Array("買超券商", "買進", "賣出", "買超張數", "賣超券商", "買進", "賣出", "賣超張數")
                
                For i = 0 To CallByName(buyerRankList, "length", VbGet) - 1
                    .Cells(i + 2, 1) = CallByName(CallByName(buyerRankList, i, VbGet), "name", VbGet)
                    .Cells(i + 2, 2) = CallByName(CallByName(buyerRankList, i, VbGet), "buyVolK", VbGet)
                    .Cells(i + 2, 3) = CallByName(CallByName(buyerRankList, i, VbGet), "sellVolK", VbGet)
                    .Cells(i + 2, 4) = CallByName(CallByName(buyerRankList, i, VbGet), "volume", VbGet)
                    .Cells(i + 2, 5) = CallByName(CallByName(sellerRankList, i, VbGet), "name", VbGet)
                    .Cells(i + 2, 6) = CallByName(CallByName(sellerRankList, i, VbGet), "buyVolK", VbGet)
                    .Cells(i + 2, 7) = CallByName(CallByName(sellerRankList, i, VbGet), "sellVolK", VbGet)
                    .Cells(i + 2, 8) = CallByName(CallByName(sellerRankList, i, VbGet), "volume", VbGet)
                Next i
                
                .Cells.Columns.AutoFit
            End With
            
            Application.ScreenUpdating = True
            
        End With
    
    
        MsgBox Stock & vbNewLine & DataTime & vbNewLine & Timer - ttt & "s", vbOKOnly, "report"  'debug
        
        Set GetXml = Nothing
        Set Jsondata = Nothing
        Set DecodeJson = Nothing
        Set buyerRankList = Nothing
        Set sellerRankList = Nothing
    
End Sub

rainbowsperm wrote:
最近下載上方網址的資料 發現下載網址是沒問題的
但試了本主題的所有下載csv的方法
都會找不到資料 卡在.send的部分

Sub get_twse_Ms()

        Dim Url As String, HTMLsourcecode As Object, XMLget As Object, temp, ttt As Double
        Set HTMLsourcecode = CreateObject("htmlfile")
        Set XMLget = CreateObject("msxml2.xmlhttp")
        
        Url = "https://www.twse.com.tw/exchangeReport/MI_MARGN?response=csv&date=20210827&selectType=MS"

        ttt = Timer
        
        With XMLget
            .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
         
            HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)
            temp = Split(HTMLsourcecode.body.innertext, " ")
        
        End With
        
        With Sheets("工作表1")
            .Cells.Clear
            .Range("a1:a" & UBound(temp) + 1) = Application.Transpose(temp)
            .Columns("A:A").TextToColumns DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Comma:=True
            .Columns.ColumnWidth = 15
        End With
 
        Set HTMLsourcecode = Nothing
        Set XMLget = Nothing
        
        Debug.Print Timer - ttt
    
End Sub


Function convertraw(rawdata)

    Dim rawstr
    Set rawstr = CreateObject("adodb.stream")
    With rawstr
        .Type = 1
        .Mode = 3
        .Open
        .Write rawdata
        .Position = 0
        .Type = 2
        .Charset = "big5"
        convertraw = .ReadText
        .Close
    End With
    Set rawstr = Nothing

End Function