- 帖子
- 23
- 主題
- 0
- 精華
- 0
- 積分
- 73
- 點名
- 101
- 作業系統
- XP
- 軟體版本
- Office 2003
- 閱讀權限
- 20
- 註冊時間
- 2012-4-21
- 最後登錄
- 2024-4-18
          
|
15#
發表於 2015-7-26 21:53
| 只看該作者
回復 azrael19
有一個延伸的問題 能否判讀如附圖內右端整排資料之漲或跌
或可將實際之箭頭方向一 ...
lcctno 發表於 2015-7-26 11:13 
用原本的方式我還不知道要怎麼做，如果你的需求只是要抓資料，下面是另一種方式你試試看...- Option Explicit
- Option Base 1
- Sub Ex()
- Dim HEAD As Variant, PARAM As Variant, PA As Variant, AR As Variant, v As Variant
- Dim i As Integer, j As Integer, k As Integer
- Dim s As String, ErrDescription As String
- Dim objCol As Object
-
- '參數 : 網址,表頭放置位址,資料放置儲存格位址,標註顏色儲存格位址
- PARAM = [{"http://www.yuantaetfs.com/api/RtNav","B1","B5","D16:D17"; "http://www.yuantaetfs.com/Home/IndexPrice","","B27","C27:C28"}]
-
- '資料表頭陣列字串
- HEAD = Array("{""資料時間"","""","""","""","""","""","""","""","""","""","""","""","""","""","""";" & _
- """基本資料"","""",""淨值"","""","""","""",""市價"","""","""","""",""折溢價"","""",""初級市場"","""",""基金"";" & _
- """股票"",""基金"",""昨收"",""預估"",""漲跌"",""漲跌幅"",""昨收"",""最新"",""漲跌"",""漲跌幅"",""折溢價"",""幅度"",""可否"",""可否"",""營業日"";" & _
- """代碼"",""名稱"",""淨值"",""淨值"","""","""",""市價"",""市價"","""","""","""","""",""申購"",""贖回"",""""}", "")
-
- 'Regular Expression
- PA = Array("{""fundId"":""[\d]+"",""etfId"":""(.+?)"",""name"":""(.+?)"",""ename"":""[^""]*"",""yestNav"":(.+?),""nav"":(.+?),""navFluct"":(.+?),""yestPrice"":(.+?),""price"":(.+?),""priceFluct"":(.+?),""yestIndex"":(.+?),""index"":(.+?),""indexFluct"":(.+?),""updateTime"":""(.+?)"",""AllowMark"":""(.+?)"",""RedemMark"":""(.+?)"",""BussMark"":""(.+?)"",[^}]+}", _
- "{""fund_id"":null,""IndexCode"":""[^""]*"",""IndexName"":""([^""]+)"",""IndexEName"":""[^""]*"",""crncy"":""[^""]*"",""area"":""D"",""DayDate"":""[^""]*"",""Close"":(.+?),""yestClose"":(.+?),""Diff"":(.+?)}")
- ActiveSheet.UsedRange.ClearContents
-
- For i = LBound(PARAM) To UBound(PARAM)
-
- '抓取JSON資料
- With CreateObject("WinHttp.WinHttpRequest.5.1")
- .Open "GET", PARAM(i, 1), False
- .send
- If 200# <> .Status Then
- ErrDescription = "網頁讀取失敗!"
- GoTo Catch
- End If
- s = .responseText
- End With
-
- With ActiveSheet
- If "" <> PARAM(i, 2) Then
- '放置表頭資料
- AR = Application.Evaluate(HEAD(i))
- .Range(PARAM(i, 2)).Resize(UBound(AR, 1), UBound(AR, 2)).Value = AR
- Erase AR
- End If
- If "" <> PA(i) Then
- '解析JSON字串中所需資料
- With CreateObject("VBScript.RegExp")
- .Global = True
- .Pattern = PA(i)
- If False = .test(s) Then: GoTo Catch
- Set objCol = Nothing
- Set objCol = .Execute(s)
- End With
- If 0 = objCol.Count Then
- ErrDescription = "資料格式解析錯誤!"
- GoTo Catch
- End If
- ReDim AR(1 To objCol.Count, 1 To objCol(1).SubMatches.Count) As Variant
- For j = 0 To objCol.Count - 1
- For k = 0 To objCol(0).SubMatches.Count - 1
- AR(j + 1, k + 1) = objCol(j).SubMatches(k)
- Next k
- Next
- End If
-
- Select Case i
- Case 1
- '重新排列及修正資料以符合網頁表格所呈現樣貌
- For j = 0 To objCol.Count - 1
- AR(j + 1, 9) = AR(j + 1, 8) '漲跌
- AR(j + 1, 8) = AR(j + 1, 7) '最新市價
- AR(j + 1, 7) = AR(j + 1, 6) '昨收市價
- AR(j + 1, 6) = Round(AR(j + 1, 5) / AR(j + 1, 3), 4) '漲跌幅
- AR(j + 1, 10) = Round(AR(j + 1, 9) / AR(j + 1, 7), 4) '漲跌幅
- AR(j + 1, 11) = AR(j + 1, 8) - AR(j + 1, 4) '折溢價
- AR(j + 1, 12) = Round(AR(j + 1, 11) / AR(j + 1, 4), 4) '幅度
- Next j
- .Range("B1").Value = "資料時間:" & Trim(objCol(0).SubMatches(11))
- With .Range(PARAM(i, 3)).Resize(UBound(AR, 1), UBound(AR, 2))
- '設定儲存格格式
- v = Split("@,@,0.00,0.00,0.00,0.00%,0.00,0.00,0.00,0.00%,0.00,0.00%", ",")
- For j = LBound(v) To UBound(v)
- .Columns(j + 1).NumberFormat = v(j)
- Next
- .Value = AR
- End With
- Erase AR
- Case 2
- For j = 0 To objCol.Count - 1
- AR(j + 1, 3) = AR(j + 1, 4) '指數漲跌
- AR(j + 1, 4) = Round(AR(j + 1, 3) / AR(j + 1, 2), 4) '漲跌幅(%)
- Next
- With .Range(PARAM(i, 3)).Resize(UBound(AR, 1), UBound(AR, 2))
- '設定儲存格格式
- v = Split("@;#,##0.00;#,##0.00;0.00%", ";")
- For j = LBound(v) To UBound(v)
- .Columns(j + 1).NumberFormat = v(j)
- Next
- .Value = AR
- End With
- Erase AR
- Case Else
- End Select
-
- '標註設定儲存格位址顏色
- With .Range(PARAM(i, 4)).Interior
- .ColorIndex = 35
- .Pattern = xlSolid
- End With
- End With
-
- Next
-
- Finally:
- Set objCol = Nothing
- Exit Sub
- Catch:
- If "" <> ErrDescription Then: MsgBox ErrDescription, vbCritical
- Err.Clear
- Resume Finally
- End Sub
|
|
發表於 2015-7-27 06:09
| 