- 帖子
- 5
- 主題
- 1
- 精華
- 0
- 積分
- 12
- 點名
- 0
- 作業系統
- windows
- 軟體版本
- 2007
- 閱讀權限
- 10
- 性別
- 男
- 來自
- 新竹
- 註冊時間
- 2012-4-19
- 最後登錄
- 2013-5-7
|
以下的程式碼是在版上看到的
請問各位大大有可能直接把資料存入ACCESS嗎
感謝
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
i = 1
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, 日期 & "_" & 股票代號 & " 第" & 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 = "無法查詢等候5秒鐘"
Application.Wait Now + TimeValue("00:00:05")
Err.Clear
Application.StatusBar = False
Resume '重返查詢
End Sub |
|
發表於 2012-4-19 15:44
| 
