- 帖子
- 184
- 主題
- 45
- 精華
- 0
- 積分
- 407
- 點名
- 0
- 作業系統
- WIN 7
- 軟體版本
- office 2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2010-8-19
- 最後登錄
- 2024-11-1
|
26#
發表於 2013-11-1 17:11
| 只看該作者
- 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("A:A").Select
- Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
- TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
- Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
- :=Array(1, 10), TrailingMinusNumbers:=True
-
- .Range("f1").Select
- Application.CutCopyMode = False
- ActiveSheet.Paste
-
- .Range("F19") = Symbol
-
- .Range("G19:L19").Select
-
- '------------------------
- .QueryTables(1).ResultRange = "" '清除Web查詢的資料
- .Names(.QueryTables(1).Name).Delete 'Web查詢的名稱
- End With
- Next
- End With
- Application.DisplayAlerts = True
- End Sub
這是我先前修改的程式 不好用
原因
.Range("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(1, 10), TrailingMinusNumbers:=True
這一段如果遇到沒有資料 程式會停擺
另外這一段
.Range("f1").Select
Application.CutCopyMode = False
ActiveSheet.Paste
雖然可以複製格式 但是陣列公式沒法啟動
以上跟各位交流
再次感謝G大的用心 謝謝 |
|
發表於 2013-11-1 16:41
| 
