麻辣家族討論版版 - Powered by Discuz! Board

標題: 交易明細下載 [打印本頁]

作者: a2305577 時間: 2012-7-31 05:28 標題: 交易明細下載

http://bsr.twse.com.tw/bshtm/

這個網站比較有人性一點參數找的到也可以設定

但是我不知道頁數有幾張

土法煉鋼一頁一頁弄也很沒有效率

查詢太多次還會被檔

請問程式該如何下載

Sub 個股交易明細下載()
Dim 股票代號 As String, 日期 As Variant, N, i As Integer, A, T As Date
Do While Not IsDate(日期)
日期 = InputBox("輸入查詢日期", "日期", Date)
If 日期 = "" Then End
Loop
Do While 股票代號 = ""
股票代號 = InputBox("股票代號", "輸入查詢之股票代號", "1101")
If 日期 = "" Then End
Loop
日期 = Format(日期, "yyyymmdd")
T = Time
With ActiveSheet
For Each N In .Names
N.Delete
Next
.Cells.Clear
Application.StatusBar = False
On Error GoTo A_Wait
With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bshtm_report_Messages.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=1", Destination:=Range("A1"))
.Name = 日期 & "_" & 股票代號 & "_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
If Application.CountA(.ResultRange) = 0 Then
MsgBox Format(日期, "0000/00/00") & " 休市!!! 或股票代號:" & 股票代號 & " 錯誤 !!!"
[A1].Select
End
End If
End With
i = 2
Do
.Cells(Rows.Count, 1).End(xlUp).Offset(1).Select
With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bshtm_report_Messages.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=" & i, Destination:=Selection)
.Name = 日期 & "_" & 股票代號 & "_" & i
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "6"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
''''''無法查詢時稍待到 A_Wait: '''''
.Refresh BackgroundQuery:=False
If Application.CountA(.ResultRange) = 0 Then GoTo Out
i = i + 1
End With
A = CreateObject("WScript.Shell").popup("請等後下載..." & Chr(10) & Chr(10) & "** 請勿按下 ** [確定]", 4, 日期 & "_" & .[F2] & " 第" & i & "頁", 16 * 3 + 0)
Application.ScreenUpdating = True
Loop
Out:
.UsedRange.Columns.AutoFit
.[A1].Select
A = CreateObject("WScript.Shell").popup("共下載" & i & "頁", 5, 日期 & "_" & 股票代號, 48 + 0)
Application.StatusBar = "共下載 " & i & "頁費時 " & Format(Time - T, "HH:MM:SS")
End With
End
A_Wait:
Application.StatusBar = "無法查詢等候10秒鐘"
Application.Wait Now + TimeValue("00:00:10")
Err.Clear
Application.StatusBar = False
Resume '重返查詢
End Sub

複製代碼

以前可以下載到...現在下不到，請求高手解惑

作者: chen_cook 時間: 2012-7-31 05:35

回復 1# a2305577

http://forum.twbts.com/viewthrea ... amp;from=indexheats
找這個版主問吧!!

作者: a2305577 時間: 2012-7-31 06:03

回復 2# chen_cook

謝謝！原來問題已有人先發現

靜待高手解決

作者: lalalada 時間: 2012-7-31 09:23

http://bsr.twse.com.tw/bshtm/

這個網站比較有人性一點參數找的到也可以設定

但是我不知道頁數有幾 ...
a2305577 發表於 2012-7-31 05:28

嗨~
剛看了一下
主要就是他的網址已經默默地改了= ="
新的是: http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=1101&FocusIndex=1
所需參數只有股票代碼而已
這樣問題應該就解決了吧:)

作者: a2305577 時間: 2012-7-31 18:03

回復 4# lalalada

這樣就無法一次自動下載了！是嗎

作者: mannyhsu 時間: 2012-8-1 00:02

回復 4# lalalada

可否幫忙後面那個頁碼, 如何取得 ?
http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=1101&FocusIndex=all_

作者: chchwa 時間: 2012-8-1 10:32

回復 4# lalalada

你這樣是第1頁，他的問題是要知道有幾頁喔

作者: lalalada 時間: 2012-8-1 10:59

本帖最後由 lalalada 於 2012-8-1 11:00 編輯

喔喔不好意思
之前我以為成功了結果跑完之後發現資料是錯的...
這是我之前寫的:
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
With WinHttpReq
.Open "POST", URL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send (varBody)
         Set oStream = CreateObject("ADODB.Stream")
         oStream.Open
         oStream.Type = 1
         oStream.Write WinHttpReq.ResponseBody
         oStream.SaveToFile ("C:\AA\temp\" & CStr(code) & ".csv")
         oStream.Close
End With
Application.Workbooks.Open ("C:\AA\temp\" & CStr(code) & ".csv")
Cells.Find(what:="sp_list").Activate
Page = Left(ActiveCell, a, b)
就如之前所說是將網頁原始檔抓下來再讀取
發現後就開始修改等真的弄好再po完整版
這幾天只能繼續用G版大之前寫的土法煉鋼抓有興趣的股票囧
目前可能要請教用PYTHON的那位囉看起來好像可以抓成csv檔(?)
不過他似乎專注於開新版而沒有要PO程式碼的意思
所以最近也要開始學了~

作者: GBKEE 時間: 2012-8-1 13:35

回復 6# mannyhsu

Option Explicit
Sub 個股交易明細下載()
Dim 股票代號 As String, 日期 As Variant, N As Name, i As Integer, T As Date, A
Do While Not IsDate(日期)
日期 = InputBox("輸入查詢日期", "日期", Date)
If 日期 = "" Then End
Loop
Do While 股票代號 = ""
股票代號 = InputBox("股票代號", "輸入查詢之股票代號", "1101")
If 日期 = "" Then End
Loop
日期 = Format(日期, "yyyymmdd")
T = Time
With ActiveSheet
.Cells.Clear
DoEvents
Application.ScreenUpdating = False
Application.StatusBar = False
With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=1", Destination:=Range("A1"))
.BackgroundQuery = True
.WebTables = "6,7"
.Refresh BackgroundQuery:=False
.ResultRange(1).End(xlDown).Offset(2).CurrentRegion.Cut .ResultRange(1).End(xlToRight).Offset(, 1)
If Application.CountA(.ResultRange) = 0 Then
MsgBox Format(日期, "0000/00/00") & " 休市!!! 或股票代號:" & 股票代號 & " 錯誤 !!!"
[A1].Select
End
End If
ActiveSheet.Names(.Name).Delete
End With
i = 2
Do
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Select
With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=" & i, Destination:=Selection)
.BackgroundQuery = True
.WebTables = "6,7"
On Error Resume Next
Do
Err.Clear
.Refresh BackgroundQuery:=False
Loop Until Err.Number = 0
On Error GoTo 0
If Application.CountA(.ResultRange) = 0 Then GoTo OUT
.ResultRange(1).End(xlDown).Offset(2).CurrentRegion.Cut .ResultRange(1).End(xlToRight).Offset(, 1)
.ResultRange(1).EntireRow.Delete
ActiveSheet.Names(.Name).Delete
i = i + 1
End With
Loop
OUT:
.[A1].Select
Application.ScreenUpdating = True
With .UsedRange
.WrapText = False
.Interior.ColorIndex = xlNone
.Font.Size = 12
.Columns.AutoFit
A = CreateObject("WScript.Shell").popup("共下載 " & i & " 頁費時 " & Format(Time - T, "hh:mm分SS秒"), 5, 日期 & "_" & 股票代號, 48 + 0)
Application.StatusBar = 日期 & " _ " & 股票代號 & " 共下載 " & i & "頁費時 " & Format(Time - T, "HH:MM:SS")
End With
For Each N In .Names
N.Delete
Next
End With
End Sub

複製代碼

作者: lalalada 時間: 2012-8-1 13:56

回復 9# GBKEE

yap 就是這個
另外提供一小段程式碼
可以免去手動輸入日期
反正他也只有一天的資料可以下載
Sheets.Add
With ActiveSheet.QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=1101&FocusIndex=All_1", Destination:=Range("A1"))
      .PreserveFormatting = True
      .RefreshStyle = xlInsertDeleteCells
      .WebSelectionType = xlSpecifiedTables
      .WebFormatting = xlWebFormattingNone
      .WebTables = "4,""table2"""
      .Refresh BackgroundQuery:=False
      End With
dataDate = Format(Cells(1, 2), "yyyymmdd")

作者: lalalada 時間: 2012-8-1 14:05

回復 GBKEE

yap 就是這個
另外提供一小段程式碼
可以免去手動輸入日期
反正他也只有一天的資料可以 ...
lalalada 發表於 2012-8-1 13:56

超過三分鐘不能編輯...
我發現日期隨便打抓到的東西都一樣!
所以也不需要特別指定了@@

作者: lalalada 時間: 2012-8-1 14:31

實際上不需要輸入日期引數就可以載入網頁~

另外想請教
.ResultRange(1).End(xlDown).Offset(2).CurrentRegion.Cut .ResultRange(1).End(xlToRight).Offset(, 1)
這兩句是什麼意思?

作者: GBKEE 時間: 2012-8-1 14:44

本帖最後由 GBKEE 於 2012-8-1 14:46 編輯

回復 11# lalalada
所以是只可以察看前一日或當日的資料
回復 12# lalalada

.ResultRange-> QueryTablet 查詢傳送來的資料範圍
.ResultRange(1).->.ResultRange.Cells(1)

vba 的說明及範例
ResultRange 屬性請參閱套用至範例特定傳回 Range 物件，該物件代表指定查詢表所覆蓋的工作表區域。唯讀。
範例
本範例對第一張查詢表中第一欄的資料進行加總，並在資料範圍下方顯示第一欄資料的總和。
Set c1 = Sheets("sheet1").QueryTables(1).ResultRange.Columns(1)
c1.Name = "Column1"
c1.End(xlDown).Offset(2, 0).Formula = "=sum(Column1)"

作者: HSIEN6001 時間: 2012-8-1 14:51

回復 10# lalalada

參考!參考!~~有誤請糾正我!

我的理解是
.RefreshStyle = xlOverwriteCells       '= xlOverwriteCells '覆蓋原欄位 = xlInsertDeleteCells '插入新資料,原資料右移

所以抓完全頁面之後的應用
Option Explicit
Sub Ex()
Dim QueryTable_Name As String
With ActiveSheet
      With .QueryTables.Add(Connection:="URL;http://******", Destination:=Range("A1"))
         QueryTable_Name = .Name
         .RefreshStyle = xlOverwriteCells       '= xlOverwriteCells '覆蓋原欄位 = xlInsertDeleteCells '插入新資料,原資料右移
         .Refresh BackgroundQuery:=False
      End With
      .Names(QueryTable_Name).Delete '刪除:查詢在工作表所定義的範圍名稱
End With

'這裡另外剪貼出去,讓檔案各自獨立
Columns("資料範圍").Select
Selection.Cut    '剪下資料的範圍
Workbooks.Add '新增資料表
Range("A1").Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs

End Sub

作者: GBKEE 時間: 2012-8-1 15:14

回復 10# lalalada

.WebTables = "4,""table2"""

修改9#如下

Option Explicit
Sub 個股交易明細下載()
Dim 股票代號 As String, N As Name, i As Integer, T As Date, A
Do While 股票代號 = ""
股票代號 = InputBox("股票代號", "輸入查詢之股票代號", "1101")
If 股票代號 = "" Then End
Loop
T = Time
With ActiveSheet
.Cells.Clear
DoEvents
Application.ScreenUpdating = False
Application.StatusBar = False
With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=" & 股票代號 & "&FocusIndex=1", Destination:=Range("A1"))
.WebFormatting = xlWebFormattingNone
.WebTables = "4,""table2"""
.Refresh BackgroundQuery:=False
If Application.CountA(.ResultRange) = 0 Then
MsgBox "股票代號:" & 股票代號 & " 錯誤 !!!"
[a1].Select
End
End If
ActiveSheet.Names(.Name).Delete
End With
i = 2
Do
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Select
With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=" & 股票代號 & "&FocusIndex=" & i, Destination:=Selection)
.WebFormatting = xlWebFormattingNone
.WebTables = "table2"
On Error Resume Next
Do
Err.Clear
.Refresh BackgroundQuery:=False
Loop Until Err.Number = 0
On Error GoTo 0
If Application.CountA(.ResultRange) = 0 Then GoTo OUT
.ResultRange(1).EntireRow.Delete
ActiveSheet.Names(.Name).Delete
i = i + 1
End With
Loop
OUT:
.[a1].Select
Application.ScreenUpdating = True
.Columns.AutoFit
A = CreateObject("WScript.Shell").popup("共下載 " & i & " 頁費時 " & Format(Time - T, "hh:mm分SS秒"), 5, "_" & 股票代號, 48 + 0)
Application.StatusBar = "股票代號 [" & 股票代號 & "] 共下載 " & i & "頁費時 " & Format(Time - T, "HH:MM:SS")
For Each N In .Names
N.Delete
Next
End With
End Sub

複製代碼

作者: lalalada 時間: 2012-8-1 16:06

回復 13# GBKEE
回復 14# HSIEN6001

感謝兩位的說明!!

作者: sd-jason 時間: 2012-8-1 22:45

請問各位大大：
為什麼我貼上以後，它一直說找不到巨集？
有沒有檔案可以讓我看一下...
感謝 !

作者: sd-jason 時間: 2012-8-1 22:55

本帖最後由 sd-jason 於 2012-8-1 22:56 編輯

各位大大：
我剛剛試完可以囉！
只是這個好像沒有辦法像上次分享的，
自動把所有的股票抓下來，
而需要一個一個去抓，
請問這要修改哪裡....
{:3_57:}

作者: lalalada 時間: 2012-8-2 02:13

回復 18# sd-jason

寫個迴圈就可以囉..
基本上就是
for x = 1 to 10
code=cells(x,1) 'cell是存放股票代碼的儲存格一開始先打好
'把code代入原程式的"股票代碼"
next

作者: a2305577 時間: 2012-8-2 19:34

回復 10# lalalada

請問要加到哪裡？這段程式....會比較快嗎？

作者: lalalada 時間: 2012-8-2 23:12

回復 20# a2305577

加在WITH ACTIVESHEET的前面
就可以一次下載很多支股票
看起來會比一支一支重新輸入快阿@@?
至少不用待在電腦前
如果你願意把全部代碼輸入的話要全部下載也是可以(?)
只是要很久所以沒試過...

作者: a2305577 時間: 2012-8-3 04:27

GBKEE大大感謝你分享上市資料抓取內碼....感恩！
上櫃可否也請你分享抓取方式
謝謝！

作者: tsuneng 時間: 2012-8-9 07:53

回復 15# GBKEE

GBKEE 大大你好!

感謝你分享上市個股成交明細資料抓取內碼,
參考大大公告的CODE ,無法成功抓取上櫃成交資料
期待大大也分享上櫃抓取CODE !!
謝謝！

作者: GBKEE 時間: 2012-8-9 08:11

回復 23# tsuneng
並非一程式可無敵的
請上傳: 上櫃成交資料網頁
我來試試看

作者: HSIEN6001 時間: 2012-8-9 10:17

本帖最後由 HSIEN6001 於 2012-8-9 10:18 編輯

回復 24# GBKEE
說的好!這幾天,連我的Code都沒產生斷點,抓取很順利
看來大家都有明智的選擇
感恩不塞車!~~謝謝^^

抓xls
優點:格式正規,處理方便
缺點:多了SaveAs 的處理,掛載時間增長

抓htm
優點:掛載時間減半
缺點:格式需再使用VBA整理過

作者: tsuneng 時間: 2012-8-9 10:26

回復 24# GBKEE

謝謝 GBKEE 大大回應!!

櫃成交資料網頁 : http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/brokerBS.php?stk_code=3527

作者: lalalada 時間: 2012-8-9 10:32

回復 25# HSIEN6001
回復 23#

印象中板上有人po過抓上櫃的code
仔細找找應該有~

還是csv好用!
現在處理上櫃資料比處理上市資料容易得多
而且上櫃給的資料格式比較整齊內容也比較完整~"~
持續努力中
最近持續進行效能改善而且喜歡一直加些有的沒的功能XD
作者: HSIEN6001 時間: 2012-8-9 10:59

回復 27# lalalada

我也覺得csv方便,一秒好幾檔 (爽!)
可惜!證交所並未將格式弄好,資料有缺~~~扼脕!

等等我分享htm 轉xls
這邊等G大分享,我們外行的乖乖地
[虛心求學]
作者: lalalada 時間: 2012-8-9 11:40

回復 28# HSIEN6001

好耶~
我也在想怎麼把htm良好的轉成csv或xls
成功的話我目前的問題幾乎就全部解決了
作者: HSIEN6001 時間: 2012-8-9 11:59

回復 29# lalalada

這邊是xls,所以
htm 的我分享在這之前的討論
http://forum.twbts.com/viewthrea ... a=pageD1&page=3
作者: GBKEE 時間: 2012-8-10 17:05

回復 26# tsuneng
讓你失望了, 試了一天仍是失敗對網頁語言不熟無法下載這網址所有的資料
http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/brokerBS.php?  嚐試用 IE 下載Tables 的內容但還是失敗
如http://forum.twbts.com/viewthread.php?tid=7395&page=1&extra=#pid42189 的5# 附檔
這http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/download_ALLCSV.php?'可下載全部CSV: 但對網頁架構不熟,寫不出它的參數
望知悉者相助
用 EXCEL  WEB的查詢也有所限制,只可查看第一頁的資料,

Option Explicit

Sub Ex()

With ActiveSheet.QueryTables.Add("URL;http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/brokerBS.php?stk_code=6121", ActiveSheet.[A1])

      .WebSelectionType = xlSpecifiedTables

      .WebFormatting = xlWebFormattingNone

      .WebTables = "11,13,14"

      .Refresh BackgroundQuery:=False

End With

End Sub
複製代碼
作者: tsuneng 時間: 2012-8-10 19:19

回復 31# GBKEE
謝謝GBKEE 大大熱心分享，感恩!!
作者: diabo 時間: 2012-8-10 20:49

回復 31# GBKEE

櫃買中心的這個SERVER端程式只接收 POST傳遞 (GET傳遞無效) 的資料，須採用 XMLHTTP 以 POST 傳遞 thePOSTdata，取得 response 後直接存成 csv 即可
thePOSTdata = "curstk=" & 股票代碼 & "&fromw=0&numbern=100&stk_date=" & 資料日期 '日期格式 1010730

thePOSTActionFile = "http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/download_ALLCSV.php"

Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")

oXMLHTTP.Open "POST", thePOSTActionFile, False

oXMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

'send request - POST

oXMLHTTP.send thePOSTdata

....
複製代碼
作者: GBKEE 時間: 2012-8-10 21:19

本帖最後由 GBKEE 於 2012-8-11 06:54 編輯

回復 33# diabo
感謝相助成功!
Option Explicit

Private Sub 下載htm()

Dim xml As Object    '用來取得網頁資料

Dim stream          'As ADODB.stream '用來儲存二進位檔案

Dim URL As String    '目的網址

Dim thePOSTdata    '參數

Set xml = CreateObject("Microsoft.XMLHTTP")

Set stream = CreateObject("ADODB.stream")

URL = "http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/download_ALLCSV.php"

thePOSTdata = "curstk=3527&stk_date=1010810"

      xml.Open "POST", URL, 0

      xml.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

      xml.send thePOSTdata

With stream

      .Open

      .Type = 1

      .write xml.ResponseBody

      If Dir("D:\3527.CSV") <> "" Then Kill "D:\3527.CSV"

      .SaveToFile ("D:\3527.CSV")

      .Close

End With

Set xml = Nothing

Set stream = Nothing

End Sub
複製代碼
作者: tsuneng 時間: 2012-8-11 08:12

回復 34# GBKEE

試了,成功!!  GBKEE 果然是高人,謝謝熱心相助!!!
作者: a2305577 時間: 2012-8-16 05:26

好厲害！厲害......
成功了
等待版主分享完整下載上櫃資料內碼
感恩

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