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

inspireme543 wrote:
1) Chrome + 開啟 Javascript

- 網頁：A區 的內容有顯示
- 網頁原始碼 ( view-source:https...)，並沒有看到 A區 相關的內容

inspireme543 wrote:
3) 使用 Chrome 的開發人員工具 -> Network -> Fetch / XHR

- Reload 頁面，發現 eqc.js。
- 故意 Block eqc.js 會造成 A區內容不顯示。
- 但是，Preview eqp.js 並非 json 之類的資料，也看不到跟 A 區相關的內容
- 找不到 A區的主要封包...

inspireme543 wrote:
2) Chrome + 關掉 Javascript
- 網頁：A區 的內容沒有顯示
- 應該是由 js 另外產生 A區內容

Sub get_agdstock()

    Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, temp, URL As String, ttt As Double
    
    Set Jsondata = CreateObject("HtmlFile")
    Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
   




    
    ttt = Timer
    
    URL = "https://agdstock.club/eqc/2330-台積電"
    
    With Xmlhttp
        .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"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send
        
        Set DecodeJson = Jsondata.JsonParse(Split(Split(.responsetext, "eqData = JSON.parse('")(1), "');" & Chr(10) & "    const eqcDom")(0))
        
    End With
    
    
    Set temp = CallByName(DecodeJson, "2022-11-25", VbGet)
    
    MsgBox Round(CallByName(temp, "e10", VbGet) / 1000, 0) & "張"
    
        
    Debug.Print Timer - ttt
        
    Set Xmlhttp = Nothing
    Set Jsondata = Nothing
    Set DecodeJson = Nothing
    Set temp = Nothing
    
    
End Sub

'原始碼裡面，還有另一份股票代號+名稱的json資料

………
………
………
Set DecodeJson = Jsondata.JsonParse(Split(Split(.responsetext, "var src = JSON.parse('")(1), "');" & Chr(10))(0))
………
………
………



 

'C、D、E、F欄，單位自行換算
'E、F欄，請自行加程式或公式處理，e2=c2-c3、e3=c3-c4... ...  f2=d2-d3、f3=d3-d4... ... 




Sub get_agdstock()

    Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, temp, item, value, total As Double, URL As String, i As Integer, j As Integer, ttt As Double
    
    Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
   
    
'以下4行是圖片，請手動輸入


    
    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Range("a1:d1") = Array("日期", "總張數", "散戶", "大戶")
    ttt = Timer
    
    URL = "https://agdstock.club/eqc/2330-台積電"
    
    With Xmlhttp
        .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"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send
        
        Set DecodeJson = Jsondata.JsonParse(Split(Split(.responsetext, "eqData = JSON.parse('")(1), "');" & Chr(10) & "    const eqcDom")(0))
    
        'stockname+id
        'Set DecodeJson = Jsondata.JsonParse(Split(Split(.responsetext, "var src = JSON.parse('")(1), "');" & Chr(10))(0))
        
        
    End With
    
    Set temp = Jsondata.GetKeys(DecodeJson)
    item = Split(temp, ",")
    
    For i = 0 To UBound(item)

            Sheets("工作表1").Cells(i + 2, 1) = item(i)
            Set value = CallByName(DecodeJson, item(i), VbGet)
            
            Sheets("工作表1").Cells(i + 2, 2) = Round(CallByName(value, "e10", VbGet) / 1000, 0) & "張"
            
            total = 0
            For j = 1 To 5
                total = total + CallByName(value, "e" & j, VbGet)
            Next j
            Sheets("工作表1").Cells(i + 2, 3) = total
            
            total = 0
            For j = 6 To 9
                total = total + CallByName(value, "e" & j, VbGet)
            Next j
            Sheets("工作表1").Cells(i + 2, 4) = total
                    
    Next i
    
        
    Debug.Print Timer - ttt
        
    Set Xmlhttp = Nothing
    Set Jsondata = Nothing
    Set DecodeJson = Nothing
    Set temp = Nothing
    Set value = Nothing
    
    
End Sub

bank87012 wrote:
版主寫的828程式碼

bank87012 wrote:
mySelect.selectedIndex = p '選擇第幾頁
mySelect.FireEvent "onchange" '改變顯示頁面時，觸發事件(event)去執行網頁上的JavaScript

'等待網頁資料完全載入(對AJAX取得資料的方式應該無效)
Do While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Loop

您1285樓問的，不是我828樓(2020/7/13)寫的範例

snare wrote:
既然 finance...(恕刪)

strainny wrote:
目前在下載營收資料時遇到下載的資料黏在一起的窘境

Function 資料下載ByXmlHttp(LinkID As String, TabRow As Integer)

    Dim URL, HTMLsourcecode, GetXml
    Dim Table
    Dim i, j, k As Integer
    Dim temp
    Dim Clipboard As Object
    
    Sheets("tmp").Cells.Clear
    
    DoEvents
    Set HTMLsourcecode = CreateObject("htmlfile")
    Set GetXml = CreateObject("msxml2.xmlhttp")
    Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
    URL = LinkID
      
    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
             
        HTMLsourcecode.body[removed] = convertraw(.ResponseBody)
        Set Table = HTMLsourcecode.all.tags("table")(TabRow)
        
        Clipboard.settext Table[removed]
        Clipboard.putinclipboard
    
        Sheets("tmp").Cells(1, 1).Select
        Sheets("tmp").PasteSpecial NoHTMLFormatting:=True
    End With
    
    Set Clipboard = Nothing
    Set HTMLsourcecode = Nothing
    Set GetXml = Nothing
    
End Function

'因語法衝突，請自行把[removed]改成 .(小數點)innerhtml
'詳細請看圖對照修改

snare wrote:
方法很多，比較簡單一...(恕刪)