1234
返回列表 上一主題 發帖

交易明細下載

a2305577

帖子
24 
主題
2 
精華
0 
積分
32 
點名
0  
作業系統
WINDOW XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
性別
男 
註冊時間
2011-10-31 
最後登錄
2018-1-17 

論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-7-31 05:28 | 只看該作者

交易明細下載

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

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

但是我不知道頁數有幾張

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

查詢太多次還會被檔

請問程式該如何下載
  1. Sub 個股交易明細下載()
  2.     Dim 股票代號 As String, 日期 As Variant, N, i As Integer, A, T As Date
  3.     Do While Not IsDate(日期)
  4.         日期 = InputBox("輸入查詢日期", "日期", Date)
  5.         If 日期 = "" Then End
  6.     Loop
  7.     Do While 股票代號 = ""
  8.         股票代號 = InputBox("股票代號", "輸入查詢之股票代號", "1101")
  9.         If 日期 = "" Then End
  10.     Loop
  11.     日期 = Format(日期, "yyyymmdd")
  12.     T = Time
  13.     With ActiveSheet
  14.         For Each N In .Names
  15.             N.Delete
  16.         Next
  17.         .Cells.Clear
  18.         Application.StatusBar = False
  19.         On Error GoTo A_Wait
  20.         With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bshtm_report_Messages.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=1", Destination:=Range("A1"))
  21.             .Name = 日期 & "_" & 股票代號 & "_1"
  22.             .FieldNames = True
  23.             .RowNumbers = False
  24.             .FillAdjacentFormulas = False
  25.             .PreserveFormatting = True
  26.             .RefreshOnFileOpen = False
  27.             .BackgroundQuery = True
  28.             .RefreshStyle = xlInsertDeleteCells
  29.             .SavePassword = False
  30.             .SaveData = True
  31.             .AdjustColumnWidth = True
  32.             .RefreshPeriod = 0
  33.             .WebSelectionType = xlEntirePage
  34.             .WebFormatting = xlWebFormattingNone
  35.             .WebPreFormattedTextToColumns = True
  36.             .WebConsecutiveDelimitersAsOne = True
  37.             .WebSingleBlockTextImport = False
  38.             .WebDisableDateRecognition = False
  39.             .WebDisableRedirections = False
  40.             .Refresh BackgroundQuery:=False
  41.             If Application.CountA(.ResultRange) = 0 Then
  42.                 MsgBox Format(日期, "0000/00/00") & " 休市!!!  或  股票代號:" & 股票代號 & " 錯誤 !!!"
  43.                 [A1].Select
  44.                 End
  45.             End If
  46.         End With
  47.         i = 2
  48.         Do
  49.             .Cells(Rows.Count, 1).End(xlUp).Offset(1).Select
  50.             With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bshtm_report_Messages.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=" & i, Destination:=Selection)
  51.                 .Name = 日期 & "_" & 股票代號 & "_" & i
  52.                 .WebSelectionType = xlSpecifiedTables
  53.                 .WebFormatting = xlWebFormattingNone
  54.                 .WebTables = "6"
  55.                 .WebPreFormattedTextToColumns = True
  56.                 .WebConsecutiveDelimitersAsOne = True
  57.                 .WebSingleBlockTextImport = False
  58.                 .WebDisableDateRecognition = False
  59.                 .WebDisableRedirections = False
  60.               ''''''無法查詢時稍待  到  A_Wait: '''''
  61.                 .Refresh BackgroundQuery:=False
  62.                 If Application.CountA(.ResultRange) = 0 Then GoTo Out
  63.                 i = i + 1
  64.             End With
  65.             A = CreateObject("WScript.Shell").popup("請等後下載..." & Chr(10) & Chr(10) & "** 請勿按下 ** [確定]", 4, 日期 & "_" & .[F2] & "  第" & i & "頁", 16 * 3 + 0)
  66.             Application.ScreenUpdating = True
  67.         Loop
  68. Out:
  69.         .UsedRange.Columns.AutoFit
  70.         .[A1].Select
  71.         A = CreateObject("WScript.Shell").popup("共下載" & i & "頁", 5, 日期 & "_" & 股票代號, 48 + 0)
  72.         Application.StatusBar = "共下載 " & i & "頁 費時 " & Format(Time - T, "HH:MM:SS")
  73.     End With
  74.     End
  75. A_Wait:
  76.     Application.StatusBar = "無法查詢等候10秒鐘"
  77.     Application.Wait Now + TimeValue("00:00:10")
  78.     Err.Clear
  79.     Application.StatusBar = False
  80.     Resume    '重返查詢
  81. End Sub
複製代碼
以前可以下載到...現在下不到，請求高手解惑
收藏 分享

chen_cook

帖子
81 
主題
2 
精華
0 
積分
95 
點名
155  
作業系統
xp 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
註冊時間
2012-2-29 
最後登錄
2025-6-4 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章
2#
發表於 2012-7-31 05:35 | 只看該作者
回復 1# a2305577


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

TOP

a2305577

帖子
24 
主題
2 
精華
0 
積分
32 
點名
0  
作業系統
WINDOW XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
性別
男 
註冊時間
2011-10-31 
最後登錄
2018-1-17 

論壇贊助勳章
3#
發表於 2012-7-31 06:03 | 只看該作者
回復 2# chen_cook


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

    靜待高手解決

TOP

lalalada

帖子
102 
主題
17 
精華
0 
積分
129 
點名
0  
作業系統
windows 
軟體版本
2010 
閱讀權限
20 
性別
男 
註冊時間
2012-5-16 
最後登錄
2020-9-2 
4#
發表於 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
所需參數只有股票代碼而已
這樣問題應該就解決了吧:)

TOP

a2305577

帖子
24 
主題
2 
精華
0 
積分
32 
點名
0  
作業系統
WINDOW XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
性別
男 
註冊時間
2011-10-31 
最後登錄
2018-1-17 

論壇贊助勳章
5#
發表於 2012-7-31 18:03 | 只看該作者
回復 4# lalalada

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

TOP

mannyhsu

帖子
19 
主題
1 
精華
0 
積分
26 
點名
0  
作業系統
windows7 
軟體版本
office2003 
閱讀權限
10 
性別
男 
註冊時間
2012-6-16 
最後登錄
2014-9-23 

論壇贊助勳章
6#
發表於 2012-8-1 00:02 | 只看該作者
回復 4# lalalada

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

TOP

chchwa

帖子
1 
主題
0 
精華
0 
積分
6 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
10 
性別
男 
註冊時間
2011-12-8 
最後登錄
2013-6-10 
7#
發表於 2012-8-1 10:32 | 只看該作者
回復 4# lalalada


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

TOP

lalalada

帖子
102 
主題
17 
精華
0 
積分
129 
點名
0  
作業系統
windows 
軟體版本
2010 
閱讀權限
20 
性別
男 
註冊時間
2012-5-16 
最後登錄
2020-9-2 
8#
發表於 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程式碼的意思
所以最近也要開始學了~

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
9#
發表於 2012-8-1 13:35 | 只看該作者
回復 6# mannyhsu
  1. Option Explicit
  2. Sub 個股交易明細下載()
  3.     Dim 股票代號 As String, 日期 As Variant, N As Name, i As Integer, T As Date, A
  4.     Do While Not IsDate(日期)
  5.         日期 = InputBox("輸入查詢日期", "日期", Date)
  6.         If 日期 = "" Then End
  7.     Loop
  8.     Do While 股票代號 = ""
  9.         股票代號 = InputBox("股票代號", "輸入查詢之股票代號", "1101")
  10.         If 日期 = "" Then End
  11.     Loop
  12.     日期 = Format(日期, "yyyymmdd")
  13.     T = Time
  14.     With ActiveSheet
  15.         .Cells.Clear
  16.         DoEvents
  17.         Application.ScreenUpdating = False
  18.         Application.StatusBar = False
  19.         With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=1", Destination:=Range("A1"))
  20.             .BackgroundQuery = True
  21.              .WebTables = "6,7"
  22.             .Refresh BackgroundQuery:=False
  23.              .ResultRange(1).End(xlDown).Offset(2).CurrentRegion.Cut .ResultRange(1).End(xlToRight).Offset(, 1)
  24.             If Application.CountA(.ResultRange) = 0 Then
  25.                 MsgBox Format(日期, "0000/00/00") & " 休市!!!  或  股票代號:" & 股票代號 & " 錯誤 !!!"
  26.                 [A1].Select
  27.                 End
  28.             End If
  29.             ActiveSheet.Names(.Name).Delete
  30.         End With
  31.         i = 2
  32.         Do
  33.             .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Select
  34.             With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=" & i, Destination:=Selection)
  35.                 .BackgroundQuery = True
  36.                 .WebTables = "6,7"
  37.                 On Error Resume Next
  38.                 Do
  39.                      Err.Clear
  40.                 .Refresh BackgroundQuery:=False
  41.                 Loop Until Err.Number = 0
  42.                 On Error GoTo 0
  43.                 If Application.CountA(.ResultRange) = 0 Then GoTo OUT
  44.                 .ResultRange(1).End(xlDown).Offset(2).CurrentRegion.Cut .ResultRange(1).End(xlToRight).Offset(, 1)
  45.                 .ResultRange(1).EntireRow.Delete
  46.                 ActiveSheet.Names(.Name).Delete
  47.                 i = i + 1
  48.             End With
  49.         Loop
  50. OUT:
  51.         .[A1].Select
  52.         Application.ScreenUpdating = True
  53.         With .UsedRange
  54.             .WrapText = False
  55.             .Interior.ColorIndex = xlNone
  56.             .Font.Size = 12
  57.             .Columns.AutoFit
  58.             A = CreateObject("WScript.Shell").popup("共下載 " & i & " 頁費時  " & Format(Time - T, "hh:mm分SS秒"), 5, 日期 & "_" & 股票代號, 48 + 0)
  59.             Application.StatusBar = 日期 & " _ " & 股票代號 & " 共下載 " & i & "頁 費時 " & Format(Time - T, "HH:MM:SS")
  60.         End With
  61.         For Each N In .Names
  62.             N.Delete
  63.         Next
  64.      End With
  65. End Sub
複製代碼

TOP

lalalada

帖子
102 
主題
17 
精華
0 
積分
129 
點名
0  
作業系統
windows 
軟體版本
2010 
閱讀權限
20 
性別
男 
註冊時間
2012-5-16 
最後登錄
2020-9-2 
10#
發表於 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")

TOP

        靜思自在 : 要比誰更受誰．不要比誰更怕誰。
1234
返回列表 上一主題