- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
5#
發表於 2011-5-3 21:41
| 只看該作者
本帖最後由 GBKEE 於 2011-5-4 09:15 編輯
回復 4# carzyindex
請耐心等候 程式在跑時 **請勿按下** [確定]
'此網頁有下載管制 須有下載時間間隔 3秒 可全部下載完成
A = CreateObject("WScript.Shell").popup("請等待4秒後下載" & Chr(10) & Chr(10) & "** 請勿按下 ** [確定]", 3, 日期 & "_" & .[F2] & " 第" & i & "頁", 16 * 3 + 0)- 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
|
|
發表於 2011-4-29 17:11
| 
