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

kurgman wrote:
不好意思我之前表達不好

https://5850web.moneydj.com/z/zg/zgb/zgb0.djhtm?a=6010&b=6010

想說是否可以將其二個下拉選項裡的內容
填入exce的a與b欄中
但b會因為a的數值不同而不同
現在我發現只能用ie的方法做到javascript

Sub Get_5850web_券商進出排行_List()

    Dim HTML As Object, GetXml As Object, UrL As String, a As String, temp, i As Integer, j As Integer
    Set HTML = CreateObject("htmlfile")
    Set GetXml = CreateObject("msxml2.xmlhttp")
    
    UrL = "https://5850web.moneydj.com/z/js/zbrokerjs.djjs"
    
    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Cells.NumberFormatLocal = "@"
    
    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 = convertraw(.ResponseBody)
        
        temp = Split(Replace(Split(HTML.body.innertext, "'; var BrokerTmpAry1,")(0), "var g_BrokerList = '", ""), ";")
        
        
        For i = 0 To UBound(temp)
            List = Split(temp(i), "!")
            
            Sheets("工作表1").Cells(r + 1, 1) = Split(List(0), ",")(1)
            Sheets("工作表1").Cells(r + 1, 2) = Split(List(0), ",")(0)
            a = Sheets("工作表1").Cells(r + 1, 2)
            
            For j = 1 To UBound(List)
                r = r + 1
                Sheets("工作表1").Cells(r, 3) = Split(List(j), ",")(1)
                Sheets("工作表1").Cells(r, 4) = Split(List(j), ",")(0)
                Sheets("工作表1").Cells(r, 5) = "https://5850web.moneydj.com/z/zg/zgb/zgb0.djhtm?a=" & a & "&b=" & Sheets("工作表1").Cells(r, 4)
            Next j
            
            With Sheets("工作表1").Range("A" & r & ":E" & r).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = vbBlue
                .Weight = xlThick
            End With
            
        Next i
                
        Sheets("工作表1").Columns.AutoFit
        
    End With
    
    
    Set HTML = Nothing
    Set GetXml = Nothing
    
End Sub



Function convertraw(rawdata)

    Dim rawstr
    Set rawstr = CreateObject("adodb.stream")
    With rawstr
        .Type = 1
        .Mode = 3
        .Open
        .Write rawdata
        .Position = 0
        .Type = 2
        .Charset = "big5"
        convertraw = .ReadText
        .Close
    End With
    Set rawstr = Nothing

End Function

snare wrote:
資料分類、整理，請自...(恕刪)

野比大雄1 wrote:
請問這個動態網站有辦法嗎?謝謝我試過用ie也不行

Sub Get_tpex_Csv()
    
    Dim Clipboard As Object, XmlHttp As Object
    Dim Url As String, Tpexcsv As String, stock_id As String
    Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set XmlHttp = CreateObject("Msxml2.XMLHTTP")

    
    On Error GoTo checkid
    
     Application.ScreenUpdating = False
     Sheets("工作表1").Cells.Clear
     
     
     Url = "https://www.tpex.org.tw/storage/emgstk/ch/new.csv"
     
     With XmlHttp
     
        .Open "GET", Url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", "https://www.tpex.org.tw/web/emergingstock/lateststats/new.htm?l=zh-tw"
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        
     End With
       
     With Clipboard
          .SetText convertraw(XmlHttp.responsebody)
          .PutInClipboard
     End With
            
     With Sheets("工作表1")
          .Cells(1, 1).Select
          .PasteSpecial NoHTMLFormatting:=True
          .Columns("A:A").TextToColumns DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Comma:=True
          .Cells(1, 1).Select
          .Columns.AutoFit
     End With

     Application.ScreenUpdating = True
    
     Set Clipboard = Nothing
     Set XmlHttp = Nothing
     
checkid:

    If Err.Number <> 0 Then
         Debug.Print Err.Description
    End If

End Sub

Function convertraw(rawdata)

    Dim rawstr
    Set rawstr = CreateObject("adodb.stream")
    With rawstr
        .Type = 1
        .Mode = 3
        .Open
        .Write rawdata
        .Position = 0
        .Type = 2
        .Charset = "big5"
        convertraw = .ReadText
        .Close
    End With
    Set rawstr = Nothing

End Function

snare wrote:
tpex 有流量限制...(恕刪)

野比大雄1 wrote:

您好 我如果想換這一個頁面資料有辦法嗎?
我都只有辦法抓到文字 沒辦法抓到數據
只要圖片的部分就好
https://mis.tpex.org.tw/ib120stk.aspx?SymbolID=1294

Sub test()
    
    Dim Clipboard As Object, XmlHttp As Object, URL As String
    Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set XmlHttp = CreateObject("Msxml2.XMLHTTP")

    
    On Error GoTo checkid
    
     Application.ScreenUpdating = False
     Sheets("工作表1").Cells.Clear
     
     
     URL = "https://mis.tpex.org.tw/Quote.asmx/GETQ20"
     
     With XmlHttp
     
        .Open "POST", URL, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", "https://mis.tpex.org.tw/ib120stk.aspx?SymbolID=1294"
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send ("SymbolID=1294")
        
     End With
       
     With Clipboard
          .SetText XmlHttp.responsetext       '
          .PutInClipboard
     End With
            
     With Sheets("工作表1")
          .Cells(1, 1).Select
          .PasteSpecial NoHTMLFormatting:=False
          .Cells(1, 1).Select
          .Columns.AutoFit
     End With

     Application.ScreenUpdating = True
    
     Set Clipboard = Nothing
     Set XmlHttp = Nothing
     
checkid:

    If Err.Number <> 0 Then
         Debug.Print Err.Description
    End If

End Sub

野比大雄1 wrote:
另外 這一個歷史數據可以抓嗎? 因為我自己弄得沒辦法修改 月份只能抓到當月
https://www.tpex.org.tw/web/emergingstock/single_historical/history.php?l=zh-tw&code=1294

萬分感謝 再麻煩您。

 URL = "https://www.tpex.org.tw/web/emergingstock/single_historical/download.php"
     
……………
……………
     
        .Open "POST", URL, False

……………
……………

        .setRequestHeader "Referer", "https://www.tpex.org.tw/web/emergingstock/single_historical/history.php?l=zh-tw&code=1294"

……………
……………


'以下這行是圖片，請手動輸入

snare wrote:
程式碼幾乎同1345...(恕刪)

alantsai5840 wrote:
如0050 結果只抓到50