- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
20#
發表於 2013-10-23 16:17
| 只看該作者
本帖最後由 GBKEE 於 2013-10-23 16:18 編輯
回復 19# pupai - Option Explicit
- Sub GetData()
- Dim DataSheet As Worksheet, Sh As Worksheet
- Dim EndDate As Date, StartDate As Date, AR, xR As Long
- Dim Symbol As Variant, Qur As String
- Set DataSheet = Sheets("代碼")
- With DataSheet
- StartDate = .[C1]
- EndDate = .[C2]
- '本資料自民國94年09月01日開始提供 *** 除錯 ***
- If StartDate < #9/1/2005# Or EndDate < #9/1/2005# Or StartDate > EndDate Or EndDate > Date Then
- MsgBox "數據有誤" & IIf(StartDate < #9/1/2005#, vbLf & "StartDate :日期 小於 94年09月01日 ", "") & _
- IIf(EndDate < #9/1/2005#, vbLf & "EndDate :日期 小於 94年09月01日 ", "") & _
- IIf(StartDate > EndDate, vbLf & "StartDate > EndDate", "") & _
- IIf(EndDate > Date, vbLf & " EndDate >" & Date, "")
- Exit Sub
- End If
- '*********************************************
- Application.DisplayAlerts = False
- For Each Sh In Sheets
- If Sh.Name <> DataSheet.Name Then Sh.Delete '刪除不必要的工作
- Next
- For Each Symbol In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) '股票的迴圈
- StartDate = .[C1] '迴圈需重新回到原本的 StartDate日期
- Set Sh = Sheets.Add(, Sheets(Sheets.Count)) '新增的工作表位於活頁簿最後面(Sheets.Count)
- DataSheet.Activate
- Do While DateSerial(Year(StartDate), Month(StartDate), 1) <= EndDate
- Qur = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?myear=" & Format(StartDate, "yyyy") & "&mmon=" & Format(StartDate, "m") & "&STK_NO=" & Symbol
- With Sh '新增的工作表
- If .QueryTables.Count = 0 Then 'Web查詢
- .QueryTables.Add "URL;" & Qur, .[M1] 'Web查詢資料在M欄
- Else
- .QueryTables(1).Connection = "URL;" & Qur
- End If
- With .QueryTables(1)
- .WebFormatting = xlWebFormattingNone
- .WebSelectionType = xlSpecifiedTables
- .WebDisableDateRecognition = True
- .WebTables = "7,8"
- .Refresh BackgroundQuery:=False
- If Application.CountA(.ResultRange) > 1 Then
- AR = .ResultRange.Offset(4)
- If Application.CountA(.Parent.[a:a]) = 0 Then AR = .ResultRange.Offset(3)
- xR = Application.CountA(.Parent.[a:a]) + 1 '.Parent :Web查詢的父層
- .Parent.Cells(xR, "A").Resize(UBound(AR, 1), UBound(AR, 2)) = AR '資料複製到 新增工作表的A欄
- End If
- End With
-
- End With
- StartDate = DateAdd("m", 1, StartDate) '日期 + 1個月
- Loop
- With Sh
- .Name = Symbol '以股票命名
- '------------------------
- .Activate
- .Range("E3").Select
- ActiveCell.FormulaR1C1 = _
- "=IF(ISERROR(DATEVALUE(1911+MID(RC[-4],1,FIND(""/"",RC[-4])-1) & MID(RC[-4],FIND(""/"",RC[-4]),LEN(RC[-4])))),"""",DATEVALUE(1911+MID(RC[-4],1,FIND(""/"",RC[-4])-1) & MID(RC[-4],FIND(""/"",RC[-4]),LEN(RC[-4]))))"
- .Range("E3").Select
- Selection.Copy
- .Columns("E:E").Select
- ActiveSheet.Paste
- .Columns("E:E").Select
- Selection.NumberFormatLocal = "[$-404]e/m/d;@"
- '------------------------
- .QueryTables(1).ResultRange = "" '清除Web查詢的資料
- .Names(.QueryTables(1).Name).Delete 'Web查詢的名稱
- End With
- Next
- End With
- Application.DisplayAlerts = True
- End Sub
|
|
發表於 2013-9-21 14:02
| 
