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

goldchiou wrote:
"https://www.wantgoo.com/stock/astock/agentstat2?stockno=8069"

goldchiou wrote:
跑出來只有 日期 收盤價 買賣超 家數差 5日集中 20日集中

Sub Get_Wantgoo_maintrend_Jsondata()

    Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, Url As String, Urla As String, ttt As Double
    
    Set Jsondata = CreateObject("HtmlFile")
    Jsondata.write ”＜script＞document.JsonParse＝function （s） ｛return eval（’（’ ＋ s ＋ ’）’）；｝＜／script＞”
'jsondata.write 這行是全形字，請自行改成半形，或直接用檔案中的程式碼
    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Range("a1:f1") = Array("date", "close", "stockAgentMainPower", "stockAgentDiff", "skp5", "skp20")
    ttt = Timer
    
    Url = "https://www.wantgoo.com/stock/8069/major-investors/main-trend-data"
    Urla = "https://www.wantgoo.com/stock/8069/major-investors/main-trend"
    
    Set Xmlhttp = CreateObject("msxml2.xmlhttp")
    With Xmlhttp
       .Open "GET", Url, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Referer", Urla
       .send
        Set DecodeJson = Jsondata.JsonParse(.responsetext)
    End With
    
    With Sheets("工作表1")
        Application.ScreenUpdating = False
        For i = 0 To CallByName(DecodeJson, "length", VbGet) - 1
            .Cells(i + 2, 1) = Left(CallByName(CallByName(DecodeJson, i, VbGet), "date", VbGet), 10)
            .Cells(i + 2, 2) = CallByName(CallByName(DecodeJson, i, VbGet), "close", VbGet)
            .Cells(i + 2, 3) = CallByName(CallByName(DecodeJson, i, VbGet), "stockAgentMainPower", VbGet)
            .Cells(i + 2, 4) = CallByName(CallByName(DecodeJson, i, VbGet), "stockAgentDiff", VbGet)
            .Cells(i + 2, 5) = CallByName(CallByName(DecodeJson, i, VbGet), "skp5", VbGet)
            .Cells(i + 2, 6) = CallByName(CallByName(DecodeJson, i, VbGet), "skp20", VbGet)
        Next i
        .Cells.EntireColumn.AutoFit
        Application.ScreenUpdating = True
    End With
        
    MsgBox "(" & Left(CallByName(CallByName(DecodeJson, i - 1, VbGet), "date", VbGet), 10) & _
    ")~(" & Left(CallByName(CallByName(DecodeJson, 0, VbGet), "date", VbGet), 10) & ")" & _
    vbNewLine & CallByName(DecodeJson, "length", VbGet) & "筆" & vbNewLine & Timer - ttt & "秒"
    
    Set Xmlhttp = Nothing
    Set DecodeJson = Nothing
    
End Sub

love732001 wrote:
想請教如果我想帶入年乖離率該如何寫巨集
因為大部分網頁的乖離率都是用圖表顯示
研究了很久實在不懂

Sub Get_nsc_Chart_Data()

    Dim Xmlhttp As Object, Url As String, Urla As String, stockno As String, data, temp, ttt As Double
    
    Sheets("工作表1").Cells.Clear
    ttt = Timer
    
    stockno = "2449"
    
    Url = "http://sod.nsc.com.tw/Z/ZC/ZCW/CZKC1.djbcd?a=" & stockno & "&b=D&c=1440"
    Urla = "http://sod.nsc.com.tw/z/zc/zcw/zcw_" & stockno & ".djhtm"
    
    Set Xmlhttp = CreateObject("msxml2.xmlhttp")
    With Xmlhttp
       .Open "GET", Url, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Referer", Urla
       .send
        data = Split(.responsetext, " ")
    End With
    
    With Sheets("工作表1")
        Application.ScreenUpdating = False
        For i = 0 To UBound(data)
             temp = Split(data(i), ",")
            .Cells(1, i + 1).Resize(UBound(temp) + 1, 1) = Application.Transpose(temp)
        Next i
         .Cells.EntireColumn.AutoFit
        Application.ScreenUpdating = True
    End With
        
    Set Xmlhttp = Nothing
    
    Debug.Print Timer - ttt
    
End Sub

love732001 wrote:
但遇到了一點迴圈問題

'b欄從b2開始~空白停止
Dim lastrow As Integer

Sub test()

    lastrow = lastrow + 1
    If Sheets("工作表1").Cells(lastrow + 1, 2) = "" Then
        lastrow = 0
        Exit Sub
    End If
    
    '需執行的程式碼位置
    '=========
    MsgBox Sheets("工作表1").Cells(lastrow + 1, 2)
    '=========
    
End Sub

bioleon69 wrote:
https://www.tdcc.com.tw/portal/zh/smWeb/qryStock...(恕刪)

snare wrote:
集保戶股權分散表?網(恕刪)