交易明細下載

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