- 帖子
- 24
- 主題
- 2
- 精華
- 0
- 積分
- 32
- 點名
- 0
- 作業系統
- WINDOW XP
- 軟體版本
- OFFICE 2003
- 閱讀權限
- 10
- 性別
- 男
- 註冊時間
- 2011-10-31
- 最後登錄
- 2018-1-17
|
交易明細下載
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
|
|
發表於 2012-7-31 05:28
| 
發表於 2012-8-10 21:19
| 
