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

yth0315 wrote:
PS: 如果之前已回過這類似問題

yth0315 wrote:
例如, 這"上市紡織分類行情", 剛進入這網頁時, 只會出現到"南緯1467.TW", 要再等一下才會出現完整的資料!
但就算是等完整資料都出現, 此時去看網頁原始碼, 還是只能看到至"南緯1467.TW", "南緯1467.TW"以下的都在網頁原始碼看不到! 這種情況下, VBA有辦法解嗎?

Sub Get_Yahoo_類股報價_Json()

    Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, Url As String, sectorId As String, exchange As String, p As Integer, Page As Integer, temp, i As Integer, ttt As Double
    
    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Range("a1:k1") = Array("股票名稱", "代號", "股價", "漲跌", "漲跌幅(%)", "開盤", "昨收", "最高", "最低", "成交量 (張)", "時間")
    Application.ScreenUpdating = False

'sectorld、exchange，2個參數，同開啟網頁時，網址上的參數
    'test
    sectorId = "4"
    exchange = "TAI"
    
    'test
    'sectorId = "33"
    'exchange = "TAI"
    
    'test
    'sectorId = "123"
    'exchange = "TWO"
    
    'test
    'sectorId = "167"
    'exchange = "TWO"
    
    'test
    'sectorId = "166"
    'exchange = "TWO"
    
    
    ttt = Timer
    
    Page = 1
    p = 0
    
    
    Do
 
        Set Jsondata = CreateObject("HtmlFile")
        Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
        
        '因語法關係無法正常顯示，Jsondata.write 這行程式碼，請手動輸入
        

        
        
        Url = "https://tw.stock.yahoo.com/_td-stock/api/resource/StockServices.getClassQuotes;exchange=" & exchange & ";offset=" & p * 30 & ";sectorId=" & sectorId & "?bkt=tw-qsp-exp-no2-1&device=desktop&ecma=default&feature=ecmaModern&intl=tw⟪=zh-Hant-TW&partner=none®ion=TW&site=finance&tz=Asia/Taipei&returnMeta=true"
    
        With Xmlhttp
    
            .Open "GET", Url, False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .setRequestHeader "Cache-Control", "no-cache"
            .setRequestHeader "Pragma", "no-cache"
            .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
            .send
            
        End With
    
    
        Set DecodeJson = CallByName(Jsondata.JsonParse(Xmlhttp.responsetext), "data", VbGet)
      
        If p = 0 Then
        
            Page = CallByName(CallByName(DecodeJson, "pagination", VbGet), "resultsTotal", VbGet)
            Debug.Print Page 'total
            If Page = 0 Then
                MsgBox "暫無資料", vbOKOnly, "Error"
                Application.ScreenUpdating = True
                Exit Sub
            End If
            
            Page = WorksheetFunction.RoundUp(Page / 30, 0)
            
        End If
      
        With Sheets("工作表1")
      
        
            For i = 0 To CallByName(CallByName(DecodeJson, "list", VbGet), "length", VbGet) - 1
                Set temp = CallByName(CallByName(DecodeJson, "list", VbGet), i, VbGet)
            
                .Cells(i + 2 + (p * 30), 1) = temp.symbolName
                .Cells(i + 2 + (p * 30), 2) = CallByName(temp, "symbol", VbGet)
                .Cells(i + 2 + (p * 30), 3) = CallByName(temp, "price", VbGet)
                .Cells(i + 2 + (p * 30), 4) = CallByName(temp, "change", VbGet)
                .Cells(i + 2 + (p * 30), 5) = "'" & temp.changePercent
                .Cells(i + 2 + (p * 30), 6) = temp.regularMarketOpen
                .Cells(i + 2 + (p * 30), 7) = temp.regularMarketPreviousClose
                .Cells(i + 2 + (p * 30), 8) = temp.regularMarketDayHigh
                .Cells(i + 2 + (p * 30), 9) = temp.regularMarketDayLow
                .Cells(i + 2 + (p * 30), 10) = temp.volumeK
                .Cells(i + 2 + (p * 30), 11) = temp.regularMarketTime
         
            Next i

    
        End With
    
    
        Set Xmlhttp = Nothing
        Set Jsondata = Nothing
        Set DecodeJson = Nothing
        Set temp = Nothing
    
        p = p + 1
        
        'Delaytick(0.5)
        
    Loop Until p = Page
    
    
    Sheets("工作表1").Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    Debug.Print Timer - ttt & "s"

    
    
End Sub


Sub Delaytick(setdelay As Single)

    Dim StartTime As Double, NowTime As Double
    StartTime = Timer * 100
    setdelay = setdelay * 100
    Do
        NowTime = Timer * 100
        DoEvents
    Loop Until NowTime - StartTime > setdelay

End Sub

yth0315 wrote:
當程式執行時, 發生物件不支援的問題! 應該是因為我用的Excel版本是2002, 這阿公級的版本無法run Jsondata.JsonParse.
可能小弟要把Xmlhttp.responsetext的內容好好study之後才能知道有沒有辦法避掉這問題吧?

'執行test
Sub test()

    Dim lastrow As Integer, i As Integer, ttt As Double
   
    ttt = Timer
    Cells.Clear
    Sheets("工作表1").Range("a1:g1") = Array("stock", "date", "close", "stockAgentMainPower", "stockAgentDiff", "skp5", "skp20")
        
    Application.ScreenUpdating = False
    
    For i = 1 To 5 '測試5筆
        Call WantGoo_Json_test(Choose(i, "2330", "2412", "2002", "2603", "2303"), i + 1)
    Next i
    Sheets("工作表1").Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    Debug.Print Timer - ttt & "s"
    
End Sub


Sub WantGoo_Json_test(stock_id As String, lastrow As Integer)

    Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, Url As String, urla As String
    Set Jsondata = CreateObject("HtmlFile")
    Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")
    
    
  



    Url = "https://www.wantgoo.com/stock/" & stock_id & "/major-investors/main-trend-data"
    urla = "https://www.wantgoo.com/stock/" & stock_id & "/major-investors/main-trend"

    
    With Xmlhttp
        .Open "GET", Url, False
        .setRequestHeader "Content-Type", "application/json; charset=utf-8"
        .setRequestHeader "Referer", urla
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/92.0.4515.107 Safari/537.36"
        .send
        Set DecodeJson = Jsondata.JsonParse(.Responsetext)
    End With

    With Sheets("工作表1")
        .Cells(lastrow, 1) = stock_id
        .Cells(lastrow, 2) = Format(CallByName(CallByName(DecodeJson, 1, VbGet), "date", VbGet) / 86400000 + #1/1/1970 8:00:00 AM#, "yyyy/mm/dd")
        .Cells(lastrow, 3) = CallByName(CallByName(DecodeJson, 0, VbGet), "close", VbGet)
        .Cells(lastrow, 4) = CallByName(CallByName(DecodeJson, 0, VbGet), "stockAgentMainPower", VbGet)
        .Cells(lastrow, 5) = CallByName(CallByName(DecodeJson, 0, VbGet), "stockAgentDiff", VbGet)
        .Cells(lastrow, 6) = CallByName(CallByName(DecodeJson, 0, VbGet), "skp5", VbGet)
        .Cells(lastrow, 7) = CallByName(CallByName(DecodeJson, 0, VbGet), "skp20", VbGet)
    End With


    Set Xmlhttp = Nothing
    Set DecodeJson = Nothing


End Sub