f3202

回復 8# iamaraymond

下載 (34.54 KB)

2018-6-17 15:37

下載 (49.67 KB)
原網頁

2018-6-17 15:39

a99之後股名下載不到
謝謝

DanielWONG

回復 2# f3202


   Very  Nice code!  Thank you very much!

DanielWONG

这里真是高手云集，以前一些以为没法用VBA提取的资料原来是可以的！那么请教下面这个网站的RSI数据可以用vba自动提取吗？ 谢谢！

http://www.aastocks.com/tc/stock/detailchart.aspx?symbol=110000#GTop

下載 (115.35 KB)

2018-6-17 20:17

iamaraymond

回復 9# f3202

這應該可以使用您在另外一個帖子回的
http://forum.twbts.com/redirect. ... 3&fromuid=30076
xmlhttp+htmlfile來抓到

f3202

回復 10# iamaraymond

9樓的圖是那個程式下載加變碼的
謝謝

iamaraymond

回復 11# f3202

試試看

1. Sub test()
   
2. 
   
3. Dim t: t = Timer
   
4. 
   
5. Cells.Clear
   
6. 
   
7. Dim myXML As Object
   
8. Set myXML = CreateObject("Microsoft.XMLHTTP")
   
9. 
   
10. Dim myHTML As Object
    
11. Set myHTML = CreateObject("HTMLFile")
    
12. 
    
13. With myXML
    
14.     .Open "GET", "https://djinfo.cathaysec.com.tw/z/ze/zef/zef.djhtm", False
    
15.     .send
    
16.    
    
17.     myHTML.body.innerHTML = convertraw(.responseBody)
    
18.     Set myTrs = myHTML.getElementsByTagName("table")(2).getElementsByTagName("tbody")(0).getElementsByTagName("tr")
    
19.     ReDim myArr(1 To myTrs.Length + 1, 1 To 4)
    
20.     i = 1
    
21.     For Each myTr In myTrs
    
22.         Set myTds = myTr.getElementsByTagName("td")
    
23.         j = 1
    
24.         For Each myTd In myTds
    
25.             myArr(i, j) = myTd.innerText
    
26.             If myTd.innerText = "" Then
    
27.                 myArr(i, j) = Right(Split(Split(Split(myTd.innerHTML, "GenLink2stk(")(1), "')")(0), "'")(1), 4) & Split(Split(Split(myTd.innerHTML, "GenLink2stk(")(1), "')")(0), "'")(3)
    
28.             End If
    
29.             j = j + 1
    
30.         Next
    
31.         i = i + 1
    
32.     Next
    
33.    
    
34. End With
    
35. Range("A1").Resize(UBound(myArr, 1), 4).Value = myArr
    
36. Range("A1").WrapText = False
    
37. Set myXML = Nothing
    
38. Application.StatusBar = "抓取完畢，共花費" & Format(Timer - t, "0.00秒")
    
39. 
    
40. End Sub
    
41. Function convertraw(rawdata)
    
42. 
    
43. Dim rawstr
    
44. Set rawstr = CreateObject("adodb.stream")
    
45. With rawstr
    
46. .Type = 1
    
47. .Mode = 3
    
48. .Open
    
49. .Write rawdata
    
50. .Position = 0
    
51. .Type = 2
    
52. '繁體通常轉成big5就可以了，簡體通常是gb2312
    
53. .Charset = "big5"
    
54. convertraw = .ReadText
    
55. .Close
    
56. End With
    
57. Set rawstr = Nothing
    
58. 
    
59. End Function

複製代碼

f3202

回復 12# iamaraymond

謝謝版大
第一個測試成功
第二個我研究看看
若有問題再請教版大
佳節愉快

iamaraymond

回復 13# f3202

OK，你可以先研究一下程式碼
看如何改成抓第二個網址的資料
這樣比較容易進步
若有問題都可以問喔~