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

rainbowsperm wrote:
我想抓取以下網站的資料
https://www.tpex.org.tw/web/bond/bonds_info/cbq/NewCB_qry.php?l=zh-tw
他有兩個下拉式選單, 並不是每個組合都有資料

rainbowsperm wrote:
另外像這種不是每個組合都有資料的,是不是只能用兩個loop去一個個的跑?

'以下是取出選單中參數的範例
'迴圈請參考下面另一個範例自行改寫






Sub Get_Tpex_BondsInfo_List()

    Dim HTML As Object, GetXml As Object, UrL As String, temp, i As Integer
    Set HTML = CreateObject("htmlfile")
    Set GetXml = CreateObject("msxml2.xmlhttp")
    
    
    Sheets("工作表1").Cells.Clear
    
    
    UrL = "https://www.tpex.org.tw/web/bond/bonds_info/cbq/NewCB_qry.php?l=zh-tw"
    
    
    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

        HTML.body.innerhtml = .responsetext
        
        
        Set temp = HTML.getElementById("yy")
        
        For i = 0 To temp.Length - 1
            Sheets("工作表1").Cells(i + 1, 1) = temp(i).Value
            Sheets("工作表1").Cells(i + 1, 2) = temp(i).innertext
        Next i
        
        
        
        Set temp = HTML.getElementById("stk_no")
        
        For i = 1 To temp.Length - 1
            Sheets("工作表1").Cells(i, 3) = temp(i).Value
            Sheets("工作表1").Cells(i, 4) = Split(temp(i).innertext, " ")(1)
        Next i
        
    End With
    
    
    Sheets("工作表1").Columns.AutoFit
    
    Set HTML = Nothing
    Set GetXml = Nothing
    
End Sub

rainbowsperm wrote:
我用456樓getpost的方法
https://www.tpex.org.tw/web/bond/bonds_info/cbq/NewCB_qry_result.php?yy=2007&stk_no=12101&l=zh-tw
但沒有回傳資料??

'以下是單筆查詢範例





Sub Get_Tpex_BondsInfo()

    Dim HTML As Object, GetXml As Object, UrL As String, yy As String, stk_no As String
    Set HTML = CreateObject("htmlfile")
    Set GetXml = CreateObject("msxml2.xmlhttp")
    
    
    Sheets("工作表1").Cells.Clear
    
    ''test1
    'yy = "2023"
    'stk_no = "12101"
    
    ''test2
    'yy = "2023"
    'stk_no = "41712"
    
    'test3
    yy = "2023"
    stk_no = "50097"
    
    
    UrL = "https://www.tpex.org.tw/web/bond/bonds_info/cbq/NewCB_qry_result.php"
    
    
    With GetXml
        
        .Open "POST", UrL, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", "https://www.tpex.org.tw/web/bond/bonds_info/cbq/NewCB_qry.php?l=zh-tw"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send ("yy=" & yy & "&stk_no=" & stk_no & "&l=zh-tw")

        HTML.body.innerhtml = .responsetext
        
        
        If HTML.body.innertext = "查無成交資訊" Then
        
            Debug.Print yy, stk_no, "查無成交資訊"
        
        Else
             
            Sheets("工作表1").Range("a1:i1") = Array("年度", "單位(仟股)", "成交金額(仟元)", "成交筆數", "最高價", "日期", "最低價", "日期", "平均價")
            Sheets("工作表1").Range("a2:i2") = Split(HTML.body.innertext, " ")
            Sheets("工作表1").Columns.AutoFit
        
        End If
        
    End With
    
    Set HTML = Nothing
    Set GetXml = Nothing
    
End Sub

bank87012 wrote:
請問這種介面網頁要如何抓取,要如何分析此網頁

'下載網址範例




Sub Get_twse_歷史重大訊息_link()

    Dim HTML As Object, Getxml As Object, table As Object, i As Integer, j As Integer, Url As String, Url_a As String, ttt As Double
    Dim Ie_Open As Boolean, PostData As String, Yy As String, co_id As String, spoke_date As String, spoke_time As String, seq_no As String
    
    Ie_Open = True '使用超連結，點擊插入註解，打開瀏覽器
    'Ie_Open = False '使用文字格式網址，點擊插入註解，但不打開瀏覽器
    
    Set HTML = CreateObject("htmlfile")
    Set Getxml = CreateObject("msxml2.xmlhttp")
    
    
    
    Yy = "112"
    co_id = "2884"
    Url = "https://mops.twse.com.tw/mops/web/ajax_t05st01"
    
    
    
    Sheets("工作表1").Cells.Clear
    Application.ScreenUpdating = False
    
    ttt = Timer
    
    With Getxml
        
       .Open "POST", 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"
       .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
       .send ("encodeURIComponent=1&step=1&firstin=1&off=1&keyword4=&code1=&TYPEK2=&checkbtn=&queryName=co_id&inpuType=co_id&TYPEK=all&co_id=" & co_id & "&year=" & Yy & "&month=&b_date=&e_date=")
       
        HTML.body.innerhtml = .responsetext
        
    End With
    
    Set table = HTML.all.tags("table")(1).Rows
    
    
    For i = 0 To table.Length - 1
        For j = 0 To table(i).Cells.Length - 1
            
            Sheets("工作表1").Cells(i + 1, j + 1) = Trim(table(i).Cells(j).innertext)
            
            If i > 0 And j = 5 Then
                spoke_date = Split(Split(table(i).Cells(j).innerhtml, "spoke_date.value='")(1), "'")(0)
                spoke_time = Split(Split(table(i).Cells(j).innerhtml, "spoke_time.value='")(1), "'")(0)
                seq_no = Split(Split(table(i).Cells(j).innerhtml, "seq_no.value='")(1), "'")(0)
                PostData = Url & "?encodeURIComponent=1&firstin=true&b_date=&e_date=&TYPEK=sii&year=" & Yy & "&month=all&type=&co_id=" & co_id & "&spoke_date=" & spoke_date & "&spoke_time=" & spoke_time & "&seq_no=" & seq_no & "&MEETING_STEP=&MODEL=&ITEM=&e_month=all&step=2&off=1"
                
                If Ie_Open = True Then
                    Sheets("工作表1").Hyperlinks.Add Sheets("工作表1").Cells(i + 1, j + 1), Address:=PostData, TextToDisplay:="詳細資料"
                Else
                    Sheets("工作表1").Cells(i + 1, j + 1) = PostData
                End If
            End If
            
        Next j
    Next i
    
    Sheets("工作表1").Columns.AutoFit
    Sheets("工作表1").Rows.AutoFit
    
    Application.ScreenUpdating = True
    
    Set HTML = Nothing
    Set Getxml = Nothing
    Set table = Nothing
    
    Debug.Print Timer - ttt & "s(download link)"
    
End Sub

'單筆下載範例，多筆請自行取用工作表1的F欄網址，用迴圈改寫





Sub Get_twse_歷史重大訊息_data()
    Dim HTML As Object, Getxml As Object, Clipboard As Object, table, Url As String, ttt As Double
    
    Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set HTML = CreateObject("htmlfile")
    Set Getxml = CreateObject("msxml2.xmlhttp")
    
    ttt = Timer
    
    
    If Sheets("工作表1").Range("f2").Hyperlinks.Count > 0 Then
        Url = Sheets("工作表1").Range("f2").Hyperlinks(1).Address
    Else
        Url = Sheets("工作表1").Range("f2").Value
    End If
    
    
    Sheets("工作表2").Cells.Clear
    
    
    With Getxml
        
        .Open "POST", Url, False
        .setRequestHeader "Referer", "https://mops.twse.com.tw/mops/web/t05st01"
        .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"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send
        HTML.body.innerhtml = .responsetext
        
    End With
    
    
    If InStr(HTML.body.innertext, "查詢過於頻繁") > 0 Then
        Debug.Print HTML.body.innertext
    Else
        Clipboard.SetText HTML.body.innerhtml
        Clipboard.PutInClipboard
            
        Sheets("工作表2").Select
        Sheets("工作表2").Cells(1, 1).Select
        Sheets("工作表2").PasteSpecial NoHTMLFormatting:=True
    End If
    
    'Sheets("工作表2").Columns.AutoFit
    'Sheets("工作表2").Rows.AutoFit
    
    
    Set HTML = Nothing
    Set Getxml = Nothing
    Set table = Nothing
    Set Clipboard = Nothing
    
    Debug.Print Timer - ttt & "s"
    
End Sub

powermac wrote:
小弟是使用EXCEL 的從WEB代入，都無法抓取到資料。

https://www.bitopro.com/ns/trading/usdt_twd

usbsilence wrote:
您在這帖小台指散戶多空比資料 已經無法執行了 請教如何修改
https://www.mobile01.com/topicdetail.php?f=511&t=4737630&p=112

卡在
datastk = Split(Split(.ResponseText, "data-stk=""")(1), """>")(0)

不知如何修改 請指導一下 謝謝您

圖片來源：財經M平方 www.macromicro.me





Sub Get_Macromicro_Charts_JSON_Data_20230913()


   Dim UrL As String, URL_a As String, GetXml As Object, Jsondata As Object, DecodeJson, BlueLine, RedLine, datastk As String

    Set Jsondata = CreateObject("HtmlFile")
    Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
  



    

    With GetXml
        
        
        UrL = "https://www.macromicro.me/charts/20069/tw-mtx-long-to-short-ratio-of-individual-player"
        URL_a = "https://www.macromicro.me/charts/data/20069"
        
        .Open "GET", UrL, False
        .setrequestheader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .Option(6) = False
        .send
        
        Cookie = Split(.GetResponseHeader("Set-Cookie"), ";")(0)
        datastk = Split(Split(.responsetext, "data-stk=""")(1), """>")(0)
        
        Debug.Print Cookie, datastk
            
        
        .Open "GET", URL_a, False
        .setrequestheader "Referer", UrL
        .setrequestheader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .setrequestheader "Cookie", Cookie
        .setrequestheader "Authorization", "Bearer " & datastk
        .send

        Set DecodeJson = CallByName(CallByName(Jsondata.JsonParse(.responsetext), "data", VbGet), "c:20069", VbGet)
        
        '台灣-小台指散戶多空比
        Set BlueLine = CallByName(CallByName(DecodeJson, "series", VbGet), 0, VbGet)
        
        '台灣 -加權股價指數
        Set RedLine = CallByName(CallByName(DecodeJson, "series", VbGet), 1, VbGet)
            
        
        '==================
        
        Application.ScreenUpdating = False
        
        With Sheets("工作表1")
            .Cells.Clear
            .Range("a1:d1") = Array("日期", "多空比", "日期", "指數")
            
            'test1
            For i = 0 To CallByName(BlueLine, "length", VbGet) - 1
                .Cells(i + 2, 1) = CallByName(CallByName(BlueLine, i, VbGet), 0, VbGet)
                .Cells(i + 2, 2) = CallByName(CallByName(BlueLine, i, VbGet), 1, VbGet)
            Next i
            
            'test2
            For i = 0 To CallByName(RedLine, "length", VbGet) - 1
                .Cells(i + 2, 3) = CallByName(CallByName(RedLine, i, VbGet), 0, VbGet)
                .Cells(i + 2, 4) = CallByName(CallByName(RedLine, i, VbGet), 1, VbGet)
            Next i
            
        End With
        
        Application.ScreenUpdating = True
        
        '==================
        

    End With
    
    
    Set GetXml = Nothing
    Set Jsondata = Nothing
    Set DecodeJson = Nothing
    Set BlueLine = Nothing
    Set RedLine = Nothing

        
    
End Sub