Board logo

標題: [原創] 集保資料(改版後) [打印本頁]

作者: iamaraymond    時間: 2018-3-27 11:21     標題: 集保資料(改版後)

最近集保網站改版,因此寫了此程式,但只是粗略地把資料抓下來,沒有多加整理

若有幫助到您,希望您在下方留個言讓我知道喔:loveliness:

個人不太喜歡IE法,所以用的是WinHttpRequest,速度快很多
  1. Sub test()

  2. Cells.Clear

  3. Dim myXML As Object
  4. Set myXML = CreateObject("WinHttp.WinHttpRequest.5.1")

  5. Dim myHTML As Object
  6. Set myHTML = CreateObject("HTMLFile")

  7. With myXML
  8.     .Open "POST", "https://www.tdcc.com.tw/smWeb/QryStockAjax.do", False    '先抓取日期
  9.     .setRequestHeader "Content-type", "application/x-www-form-urlencoded;charset=UTF-8"
  10.     .send "REQ_OPR=qrySelScaDates"
  11.    
  12.     myText = .responseText
  13.     myText1 = Split(myText, ",")
  14.     k = 1
  15.     For Each myText2 In myText1
  16.         Cells(1, k) = Replace(myText2, Chr(34), "")
  17.         Cells(1, k) = Replace(Cells(1, k), "[", "")
  18.         Cells(1, k) = Replace(Cells(1, k), "]", "")
  19.         k = k + 1
  20.     Next
  21.    
  22.     i = 6
  23.    
  24.     For Each myDate In Range("A1:BH1").Value
  25.         
  26.         .Open "POST", "https://www.tdcc.com.tw/smWeb/QryStockAjax.do", False    '代入日期撈資料
  27.         .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
  28.         .send "scaDates=" & myDate & "&scaDate=" & myDate & "&SqlMethod=StockNo&StockNo=2330&StockName=&REQ_OPR=SELECT&clkStockNo=2330&clkStockName="
  29.       
  30.         myHTML.body.innerHTML = .responseText
  31.    
  32.         Set myTable = myHTML.getElementsByTagName("table")(7)
  33.         
  34.         For Each myRow In myTable.Rows
  35.             j = 1
  36.             For Each myCell In myRow.Cells
  37.                 Cells(i, j) = myCell.innerText
  38.                 j = j + 1
  39.             Next
  40.             i = i + 1
  41.         Next
  42.         i = i + 5
  43.         L = L + 1
  44.         If L > 10 Then Exit For '要抓幾筆資料
  45.     Next
  46.    
  47. End With
  48. Set myXML = Nothing
  49. Set myHTML = Nothing

  50. End Sub
複製代碼

作者: joey0415    時間: 2018-3-27 11:36

回復 1# iamaraymond

感謝您的分享,自己星期天也花點時間改程式,先找日期後,再使用query table方式抓取,您的方式也不錯

提供一個方向

https://data.gov.tw/dataset/11452

這裏提供每週所有股票一起下載,不過要每週抓取,沒有以前的資料,如果不急的話,用這個網站累積自己的資料庫才是最棒的,每星期只抓一次
作者: cji3cj6xu6    時間: 2018-3-27 17:17

有看到了,謝謝!!

但請問一下要如何修改股票代號為變數??
作者: iamaraymond    時間: 2018-3-28 09:58

回復 2# joey0415

感謝你的分享,您提供的網站真的很棒,只是小弟真的很缺乏每周都去抓資料的毅力XD
QueryTable也不錯,因為這個網站資料較少,所以可以執行很快,但如果碰到很龐大的資料時可能就會跑很久,所以不知不覺就養成用XMLHTTP抓資料的習慣了
作者: iamaraymond    時間: 2018-3-28 10:04

回復 3# cji3cj6xu6


例如說可以在B3儲存格輸入股票代號,然後指定給變數,長這樣
stockno=[B3]
或是用inputbox
stockno=inputbox("請輸入股票代號")

接著把原程式碼的第32行改成
.send "scaDates=" & myDate & "&scaDate=" & myDate & "&SqlMethod=StockNo&StockNo=" & stockno & "&StockName=&REQ_OPR=SELECT&clkStockNo=" & stockno & "&clkStockName="
把原本的2330用變數取代,記得字串跟變數要用&連接
作者: cji3cj6xu6    時間: 2018-3-28 14:03

萬分感謝~~
作者: cji3cj6xu6    時間: 2018-3-28 15:15

Dear iamaraymond 大,

有看到兩個問題,不曉得其他人是否也遇到:
1.  日期的部分你抓下來後放在A1, B1, C1.......,並不是放在每份資料的上方,不過瑕不掩瑜,看一下就懂了。
2.  當按下 Run後,會出現執行階段錯誤訊息並指向於 (.send "REQ_OPR=qrySelScaDates"),於是我在開頭的位置寫入了 On Error Resume Next ,之後就正常了,不曉得會有後遺症嗎?

還有個小問題想問一下,
請問我想跳著抓資料,例如:兩星期抓一筆,不曉得要修改哪裡?若有空,再請指導一下。謝謝~~
作者: cji3cj6xu6    時間: 2018-3-28 15:53

Dear iamaraymond 大,

Sorry, 我仔細看了一下,我大概知道該如何修改成我要的東西了。
麻煩您了~~
作者: bhsm    時間: 2018-3-28 17:55

回復 5# iamaraymond
請教iamaraymond大:如何把抓下來的日期放在每份資料的上方,而不是放在A1, B1, C1.......,謝謝
作者: quickfixer    時間: 2018-3-28 18:06

本帖最後由 quickfixer 於 2018-3-28 18:14 編輯

我認為這邊的程式完成度較高
而且更新程式非常的快,時間比樓主還早幾天
可惜沒什麼人看
https://www.mobile01.com/topicdetail.php?f=511&t=4737630
作者: iamaraymond    時間: 2018-3-28 21:51

回復 9# bhsm
  1. Sub test()

  2. stockno = InputBox("請輸入股票代號")
  3. If stockno = "" Then Exit Sub
  4. Application.ScreenUpdating = False
  5. [A4].CurrentRegion.Clear

  6. t = Timer

  7. Dim myXML As Object
  8. Set myXML = CreateObject("WinHttp.WinHttpRequest.5.1")

  9. Dim myHTML As Object
  10. Set myHTML = CreateObject("HTMLFile")

  11. myLimit = 10 '近幾筆資料數

  12. ReDim myDateArr(1 To 60, 1 To 1)
  13. ReDim myValArr(1 To 25, 1 To myLimit * 5)

  14. With myXML
  15.     .Open "POST", "https://www.tdcc.com.tw/smWeb/QryStockAjax.do", False    '先抓取日期
  16.     .setRequestHeader "Content-type", "application/x-www-form-urlencoded;charset=UTF-8"
  17.     .send "REQ_OPR=qrySelScaDates"
  18.    
  19.     k = 1
  20.     For Each myText2 In Split(.responseText, ",")
  21.         myDateArr(k, 1) = Replace(Replace(Replace(myText2, Chr(34), ""), "[", ""), "]", "")
  22.         k = k + 1
  23.     Next
  24.    
  25.     mycount = 1
  26.     For Each myDate In myDateArr
  27. retry:
  28.         .Open "POST", "https://www.tdcc.com.tw/smWeb/QryStockAjax.do", False    '代入日期撈資料
  29.         .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
  30.         .send "scaDates=" & myDate & "&scaDate=" & myDate & "&SqlMethod=StockNo&StockNo=" & stockno & "&StockName=&REQ_OPR=SELECT&clkStockNo=" & stockno & "&clkStockName="
  31.         
  32.         If InStr(1, .responseText, "無此資料") <> 0 Then GoTo retry
  33.         
  34.         myHTML.body.innerHTML = .responseText
  35.         
  36.         Set mytable = myHTML.getElementsByTagName("table")(7)
  37.         
  38.         i = 1
  39.         
  40.         For Each myRow In mytable.Rows
  41.             
  42.              j = 5 * (myLimit - mycount) + 1
  43.             For Each myCell In myRow.Cells
  44.                 myValArr(i, j) = myCell.innerText
  45.                 j = j + 1
  46.             Next
  47.             i = i + 1
  48.         Next
  49.         Cells(4, j - 5) = myDate
  50.         Debug.Assert Cells(4, j - 4) = ""
  51.         mycount = mycount + 1
  52.         If mycount = myLimit + 1 Then Exit For '要抓幾筆資料
  53.     Next
  54. [A3] = "證券名稱:" & Split(Split(.responseText, "證券名稱:")(1), "<")(0)
  55. [A5].Resize(UBound(myValArr), 5 * myLimit).Value = myValArr

  56. End With

  57. Erase myDateArr
  58. Erase myValArr
  59. Set myXML = Nothing
  60. Set myHTML = Nothing

  61. Debug.Print Format(Timer - t, "0.00秒")
  62. Application.ScreenUpdating = True
  63. End Sub
複製代碼
試看看這個吧~
作者: iamaraymond    時間: 2018-3-28 21:55

本帖最後由 iamaraymond 於 2018-3-28 22:02 編輯

回復 10# quickfixer

這個文之前我也有看過,Snare大的程式當然比我這種門外漢強很多XD
只是我比較習慣把每一周都列出來,所以若您有興趣的話可以看看我剛剛新放上去的貼文
至於速度在其他條件差不多的情況下,主要是取決於發了多少Request,在他的code中只抓了2個禮拜的資料,但我抓了10個禮拜的,所以速度會比較慢
作者: iamaraymond    時間: 2018-3-28 21:59

回復 7# cji3cj6xu6


問題1:我剛剛新上傳了Code,可以參考看看
問題2:因為我沒遇到這個狀況,所以不確定

至於要跳著抓其實方法很多,例如用if設定計數器0和1,當等於1時才抓
或是判斷L是不是偶數之類的
作者: quickfixer    時間: 2018-3-28 22:03

本帖最後由 quickfixer 於 2018-3-28 22:11 編輯

回復 12# iamaraymond


   他看起來像是股票門外漢 :lol
速度的話,他244樓有玩過一個8開excel , 20多秒就抓玩3千多筆集保資料 XD
可惜網站改版後,他沒更新,那個範例沒辦法玩了

你的程式多加上on error goto或是on error resume 會比較好
cji3cj6xu6  的問題2 ,我也有遇到

最近網站會突然出現什麼安全性連線錯誤的
在這一行就會出錯
.send "REQ_OPR=qrySelScaDates"
作者: iamaraymond    時間: 2018-3-28 22:19

本帖最後由 iamaraymond 於 2018-3-28 22:21 編輯

回復 14# quickfixer

你們的錯誤是不是"安全通道支援發生錯誤 "?
如果是的話,我之前好像有看到有個解決方法是
打開註冊表(搜尋regedit)
    [attach]28487[/attach]

然後依據電腦情況
(for Windows 7 64 bits)
[HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Internet Settings\WinHttp]
"DefaultSecureProtocols"=dword:00000a00

(for Windows 7 32 bits)
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\WinHttp]
"DefaultSecureProtocols"=dword:00000a00

參考看看

增加速度還有個方法是用陣列,速度真的差很多,原本要跑3,4秒的東西都只要0.X秒就好了XD
作者: quickfixer    時間: 2018-3-28 22:20

回復 2# joey0415

謝謝你分享這,2015年就有的網站,今天才知道原來有整理好的資料可以下載
    https://data.gov.tw/dataset/11452
作者: cji3cj6xu6    時間: 2018-3-29 09:14

回復 15# iamaraymond


試過了,一開始找不到DefaultSecureProtocols,安裝了修正程式後找到它,但依舊有同樣的問題,不用管它了。

謝謝~~
作者: bhsm    時間: 2018-3-29 16:28

回復 11# iamaraymond
謝謝iamaraymond大
作者: BANK870    時間: 2019-1-31 23:08

請問若需要更改為集保大於400張以上趨勢比較該如何變更
作者: peter95    時間: 2020-11-15 02:18

回復 2# joey0415

小弟不才 想請問 我將檔案抓下來了
但小弟不知如何 彙整
小弟想彙整
1000張以上的比例
200張以下的比例

想請大大幫忙  教教小弟
非常感謝您的幫忙
謝謝
作者: dino123    時間: 2022-9-9 23:50

謝謝版主開版,程式我有拿來改後使用
但上星期(11109)集保的網站改版了
我自己改不出來抓取,能否改一下呢
作者: quickfixer    時間: 2022-9-10 01:05

本帖最後由 quickfixer 於 2022-9-10 01:08 編輯

回復 21# dino123

參考資料
    https://www.mobile01.com/topicdetail.php?f=511&t=4737630&p=125
    https://www.mobile01.com/topicdetail.php?f=511&t=4737630&p=126

[attach]35198[/attach]
  1. Sub Get_tdcc()
  2.    
  3.    
  4.     Dim Html As Object, GetXml As Object, r As Integer, url_a As String, temp() As String, ttt As Double
  5.     Dim SYNCHRONIZER_TOKEN As String, firDate, StockID As String, StockName As String
  6.     Set Html = CreateObject("htmlfile")
  7.     Set GetXml = CreateObject("msxml2.xmlhttp")
  8.    
  9.    
  10.     ttt = Timer
  11.     Application.ScreenUpdating = False
  12.     On Error GoTo redownload

  13.    
  14.     'StockID = "2002"
  15.     StockID = "2330"
  16.    
  17. retry1:

  18.     With GetXml
  19.         .Open "GET", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
  20.         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  21.         .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
  22.         .send
  23.         
  24.         Html.body.innerhtml = .responsetext
  25.         firDate = Split(Trim(Html.getElementById("scaDate").innertext), " ")
  26.         
  27.         If IsEmpty(firDate) = True Then
  28.            Debug.Print "get day error"
  29.            Delaytick (0.5)
  30.            r = r + 1
  31.            Debug.Print r
  32.            If r > 3 Then
  33.                MsgBox "線上日期無法更新,請稍後重試", vbOKOnly, "Error"
  34.                Exit Sub
  35.            End If
  36.            If Err.Number <> 0 Then
  37.                Debug.Print Err.Description
  38.            End If
  39.            On Error GoTo -1
  40.            Err.Clear
  41.            GoTo retry1
  42.         End If
  43.         
  44.     End With
  45.    
  46.    
  47.    
  48.    
  49. retry2:
  50.    
  51.     For d = 0 To 9 '近十周
  52.    
  53.         With GetXml
  54.             .Open "GET", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
  55.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  56.             .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
  57.             .send
  58.         
  59.             Html.body.innerhtml = .responsetext
  60.             SYNCHRONIZER_TOKEN = Html.getElementById("SYNCHRONIZER_TOKEN").Value
  61.    
  62.         
  63.         End With
  64.            
  65.          
  66.         url_a = "SYNCHRONIZER_TOKEN=" & SYNCHRONIZER_TOKEN & "&SYNCHRONIZER_URI=%2Fportal%2Fzh%2FsmWeb%2FqryStock&method=submit&firDate=" & firDate(d) & "&scaDate=" & firDate(d) & "&sqlMethod=StockNo&stockNo=" & StockID & "&stockName="
  67.         
  68.         With GetXml
  69.             .Open "POST", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
  70.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  71.             .setRequestHeader "Referer", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock"
  72.             .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
  73.             .send (url_a)
  74.             
  75.             Html.body.innerhtml = .responsetext
  76.         
  77.             If d = 0 Then
  78.                 StockName = Replace(Split(Split(.responsetext, "證券代號:")(1), "</p>")(0), Chr(10), "")
  79.                 StockName = "證券代號:" & Replace(Replace(StockName, " ", ""), "<br>", " ")
  80.                 Sheets("工作表1").Cells.Clear
  81.                 Sheets("工作表1").Columns.ColumnWidth = 16
  82.                 Sheets("工作表1").Range("a1") = StockName
  83.             End If
  84.                
  85.             Set Table = Html.all.tags("table")(1).Rows
  86.             
  87.             If Table(1).Cells(0).innertext = "查無此資料" Then
  88.                 Delaytick (0.3)
  89.                 r = r + 1
  90.                 If r > 5 Then
  91.                     MsgBox StockID & vbNewLine & firDate & ",此日期無資料或連線異常,請稍後再試", vbOKOnly, "Error"
  92.                     Set Table = Nothing
  93.                     Set Html = Nothing
  94.                     Set GetXml = Nothing
  95.                     Application.ScreenUpdating = True
  96.                     Exit Sub
  97.                 End If
  98.                 GoTo retry2
  99.             End If
  100.             
  101.                
  102.             ReDim temp(1 To Table.Length - 1, Table(2).Cells.Length - 1)
  103.                
  104.             With Sheets("工作表1")
  105.                
  106.             
  107.                 For i = 1 To Table.Length - 1
  108.                     
  109.                     For j = 0 To Table(i).Cells.Length - 1
  110.                         temp(i, j) = Table(i).Cells(j).innertext
  111.                     Next j
  112.                 Next i
  113.             
  114.                 .Range("a2").Offset(, d * 5) = firDate(d)
  115.                 .Range("a3:e3").Offset(, d * 5) = Array("序", "持股", "人數", "股數", "比例%")
  116.                 .Range(.Cells(4, 1), .Cells(i + 2, 5)).Offset(, d * 5) = temp()
  117.             
  118.             End With

  119.         End With
  120.    
  121.     Next d
  122.    
  123.     Set Table = Nothing
  124.     Set Html = Nothing
  125.     Set GetXml = Nothing
  126.     Application.ScreenUpdating = True
  127.    
  128.     Debug.Print Timer - ttt
  129.     Exit Sub
  130.    
  131. redownload:
  132.     r = r + 1
  133.     Debug.Print "http 404"
  134.     Delaytick (1.3)
  135.     If r > 3 Then
  136.        MsgBox "連線異常,請稍後再試", vbOKOnly, "Error"
  137.       
  138.        'Stop 'debug
  139.       
  140.        Set Table = Nothing
  141.        Set Html = Nothing
  142.        Set GetXml = Nothing
  143.        Application.ScreenUpdating = True
  144.        Exit Sub
  145.    
  146.     End If
  147.    
  148.     If Err.Number <> 0 Then
  149.         Debug.Print Err.Description
  150.     End If
  151.    
  152.     On Error GoTo -1
  153.     Err.Clear
  154.    
  155.     GoTo retry2


  156. End Sub

  157. Sub Delaytick(setdelay As Single)
  158.    
  159.     Dim StartTime As Double, NowTime As Double
  160.     StartTime = Timer * 100
  161.     setdelay = setdelay * 100
  162.     Do
  163.       NowTime = Timer * 100
  164.       DoEvents
  165.     Loop Until NowTime - StartTime > setdelay
  166.    
  167. End Sub
複製代碼

作者: dino123    時間: 2022-9-11 11:45

回復 22# quickfixer


    感謝回復…但我後來用的抓法,好像不太一樣,我用WinHttp 似乎快很多。 我把我用的程式貼在下面新的一則貼文
作者: dino123    時間: 2022-9-11 11:57

我的程式,一次會抓取一年下來的TDCC 資料
不曉得這次改版後,我的程式那邊對應不到,

Sub GoTDCC1yr()
'
' GoTDCC1yr Macro
'
Dim TWYear, CEYear As String
    For m = 1 To 51
        Dim WinHttp As Object, DOM As Object, Table As Object
        Dim url As String, Title() As String, Stockid As String, weekDate As String
        Dim i As Integer, j As Integer

        TWYear = Sheets("三大法人").Cells(m, "O") '民國年日期
        CEYear = Sheets("三大法人").Cells(m, "P")  '西元年日期
        Sheets(TWYear).Activate
StartTDCC:
        Stock = Worksheets("三大法人").Range("M1").Value  '股票代碼
        weekDate = Sheets("三大法人").Cells(m, "P")   '西元年日期 tdcc 用西元年月日
        url = "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock"  ' 改這樣是否正確?
        '  url = "https://www.tdcc.com.tw/smWeb/QryStockAjax.do"    原本url

        Set WinHttp = CreateObject("winhttp.winhttprequest.5.1")
        Set DOM = CreateObject("htmlfile")

        With WinHttp                                    '這裡不知如何改對應這次的改版
            .Open "POST", url, False
            .setrequestheader "Content-Type", "application/x-www-form-urlencoded"
            .send "scaDate=" & weekDate & "&clkStockNo=" & Stock & "&REQ_OPR=SELECT"
        
            If .Status = 200 Then
                DOM.body.innerHTML = .responsetext
            End If
        End With

        Set Table = DOM.getElementsByTagName("table")
        i = 1
        For Each tr In Table(6).Rows                                                     ' 還是回傳資料要改?
            j = 1
            For Each td In tr.Cells
                Sheets(TWYear).Cells(i, j) = td.innerText
                j = j + 1
            Next
            i = i + 1
        Next
   
        i = 2
        For Each tr In Table(7).Rows
            j = 1
            For Each td In tr.Cells
                Sheets(TWYear).Cells(i, j) = td.innerText
                j = j + 1
            Next
            i = i + 1
        Next
   
        Set Table = Nothing
        Set DOM = Nothing
        Set WinHttp = Nothing
              
    Next
   
End Sub
作者: quickfixer    時間: 2022-9-11 19:41

回復 24# dino123


現在send 2次,要多抓一次動態的key    SYNCHRONIZER_TOKEN
所以改版後下載時間會是改版前的2倍
你沒檔案我不知道cell內是什麼東西

22#  9改成51,就是1年
For d = 0 To 9 '近十周
For d = 0 To 51
作者: quickfixer    時間: 2022-9-12 06:54

回復 25# quickfixer


    訂正,不能用51,有時候是50
修正用ubound
For d = 0 To UBound(firDate)




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)