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

snare wrote:
不是，我在291樓解釋過了(blob url)
一字未改
您290樓檔案，也可以正常執行
也許是您的網路問題，可能是設定了什麼奇怪的dns、proxy server...(恕刪)

川頁543 wrote:
http://www.masterlink.com.tw/stock/individual/information/Info_15.aspx
目前坊間可直接匯入的格式幾乎都是這一個格式的,可惜的是沒有均價的資訊
...(恕刪)

川頁543 wrote:
剛才看到玩股網有滿完整的數據,正是我所想要的,如下連結
https://www.wantgoo.com/stock/astock/agentstat?stockno=2303&type=3.5
不曉得這連結是否可依您所列的方法來克服資料匯入的問題?...(恕刪)

'================================================
'程式碼放在模組裡
'================================================

Sub Getwantgoo_Jsondata()

    Dim Xmlhttp As Object, Jsondata As Object, getkey As Object, DecodeJson, Wantgoodata, temp, buy As Integer, sell As Integer
    Dim Url As String, url_a As String, url_b As String, stock As String, startday As String, endday As String, total As String

    Set getkey = CreateObject("VBScript.RegExp")
    Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")
    Set Jsondata = CreateObject("HtmlFile")
    



    
    On Error Resume Next
    
    Sheets("工作表1").Cells.Clear
    Application.ScreenUpdating = False
    
   
    stock = InputBox("股票代號", , "2317")
    endday = InputBox("結束日期(8碼數字)", , CheckWeekDay(Date))
    startday = InputBox("開始日期(8碼數字)", , CheckWeekDay(DateValue(Format(endday, "####-##-##")) - 10))
        
    If endday = "" Or startday = "" Or stock = "" Or Len(startday) <> 8 Or Len(endday) <> 8 Then
        MsgBox "資料可能輸入錯誤", vbOKOnly, "請重新輸入"
        Exit Sub
    End If
    
    If startday > endday Or _
       endday > CheckWeekDay(Date) Or endday > CheckWeekDay(DateValue(Format(endday, "####-##-##"))) Or _
       startday > CheckWeekDay(DateValue(Format(startday, "####-##-##"))) Or startday < CheckWeekDay(Date - 30) Then
       MsgBox "日期範圍可能錯誤", vbOKOnly, "請重新輸入"
       Exit Sub
    End If
    
    
    ttt = Timer
    
    Url = "https://www.wantgoo.com/stock/astock/agentstat_ajax?StockNo=" & stock & "&Types=3.5&StartDate=" & startday & "&EndDate=" & endday & "&Rows=35"
    url_a = "https://www.wantgoo.com/stock/astock/agentstat?stockno=" & stock & "&type=3.5"
    url_b = "https://www.wantgoo.com/stock/astock/agentstat_total_ajax?StockNo=" & stock & "&StartDate=" & startday & "&EndDate=" & endday & "&Rows=35"
    
    
    With Xmlhttp
        
       .Open "GET", url_b, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Referer", url_a
       .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)
       total = Replace(Replace(CallByName(DecodeJson, "returnValues", VbGet), "[", ""), "]", "")
        
       .Open "GET", Url, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Referer", url_a
       .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
       
       If Len(.responsetext) = 45 Then
          MsgBox "資料輸入錯誤", vbOKOnly, "請重新輸入"
          Exit Sub
       End If
        
       Set DecodeJson = Jsondata.JsonParse(.responsetext)
        
       With getkey
            .Pattern = "{[^{]+}"
            .IgnoreCase = True
            .MultiLine = False
            .Global = True

            Set Wantgoodata = .Execute(Replace(Replace(CallByName(DecodeJson, "returnValues", VbGet), "[", ""), "]", ""))
            
            .Pattern = "{|}|"""
            total = .Replace(total, "")
            For i = 1 To Wantgoodata.Count
                c = 0
                temp = Split(.Replace(Wantgoodata(i - 1), ""), ",")
                For j = 0 To UBound(temp) - 1
                    If j < 3 Or j > 6 Then
                        c = c + 1
                        If Split(temp(j), ":")(1) = "null" Then
                            Sheets("工作表1").Cells(i + 1, c) = ""
                        Else
                            Sheets("工作表1").Cells(i + 1, c) = Split(temp(j), ":")(1)
                        End If
                    End If
                Next j
            Next i
        End With
       
    End With
    
    
    With Sheets("工作表1")
        .Select
        buy = .Range("A2").End(xlDown).Row - 1
        sell = .Range("F2").End(xlDown).Row - 1

        .Range("a1:j1") = Array("買超券商(" & buy & "筆)", "買張", "賣張", "買超", "均價", "賣超券商(" & sell & "筆)", "買張", "賣張", "賣超", "均價")
        .Columns.AutoFit
        .Cells(1, 1).Select
    End With
    
    Application.ScreenUpdating = True
    
    
    Set Xmlhttp = Nothing
    Set DecodeJson = Nothing
    Set temp = Nothing
    Set getkey = Nothing
    Set Jsondata = Nothing
    
    
    MsgBox "股票代號:" & stock & vbNewLine & vbNewLine & _
    "結束日期" & endday & vbNewLine & "開始日期" & startday & vbNewLine & vbNewLine & _
    Split(total, ",")(0) & vbNewLine & _
    Split(total, ",")(1) & vbNewLine & _
    Split(total, ",")(2) & vbNewLine & _
    Split(total, ",")(4) & vbNewLine & vbNewLine & _
    "買超資料筆數合計：" & buy & "筆" & vbNewLine & _
    "賣超資料筆數合計：" & sell & "筆" & vbNewLine & _
    "使用時間" & Round(Timer - ttt, 2) & "秒", vbOKOnly, "下載完成"

    
    
    
End Sub


Function CheckWeekDay(day As Date) As String

    CheckWeekDay = Format(day, "yyyymmdd")
    If Weekday(day) = 7 Then CheckWeekDay = Format(day - 1, "yyyymmdd")
    If Weekday(day) = 1 Then CheckWeekDay = Format(day - 2, "yyyymmdd")
    
End Function








'================================================

為什麼要注意，因為就算用了錯誤(沒開盤)的日期，網站不會有錯誤訊息
網站一樣會回傳"不知道那一天的資料"