Board logo

標題: [發問] 使用 msXML2.xmlHTTP 取得股票交易資料 [打印本頁]
作者: Scott090    時間: 2017-6-26 18:05     標題: 使用 msXML2.xmlHTTP 取得股票交易資料

請問大師前輩如何以 xmlhttp 的方法取得網頁中如下圖的資料：
[attach]27382[/attach]
  1. Sub WebData()
  2.     Dim strURL$
  3.     Dim respAA
  4.     strURL = "https://tw.stock.yahoo.com/q/q?s=2330" '網頁地址
  5.     [A1].CurrentRegion = ""
  6.     Dim oXmlhttp As Object, oHtmldoc As Object
  7.     Set oXmlhttp = CreateObject("msxml2.xmlhttp")
  8.     Set oHtmldoc = CreateObject("htmlfile")
  9.     With oXmlhttp
  10.         .Open "Get", strURL, False
  11.         .send
  12.         
  13.         '-------------------------------------------------
  14.         '如何取得網頁中的表格資料?
  15.         '及 表格中 第3欄第2列資料?
  16.         '-------------------------------------------------
  17.         
  18.         
  19.     End With
  20. End Sub
複製代碼
非常感恩
作者: Scott090    時間: 2017-6-30 05:40

回復 1# Scott090


請問那一位高手願意協助

網頁地址如下：l   
https://tw.stock.yahoo.com/q/q?s=2330

謝謝
作者: prin.huang    時間: 2017-6-30 15:18

提供自己寫的讀取table程式碼，但套用到你提供的網頁，table讀出來只有1個欄位，如下圖
"股票
代號時間成交買進賣出漲跌張數昨收開盤最高最低個股資料
2330台積電
加到投資組合
14:30208.5208.0208.5▽1.5 30,867210.0206.5208.5206.5成交明細
技術　新聞
基本　籌碼
個股健診"

不知有高手有方法解決嗎？
  1. Sub main()
  2. Dim URL$, VV As Boolean, AB() As String

  4. URL = "https://tw.stock.yahoo.com/q/q?s=2330"
  5. AB = GetWebTb1(URL, 6, 1, 1, VV)
  6. If VV = True Then ActiveSheet.Range("A1") = AB

  8. End Sub

  10. Private Function GetWebTb1(sURL00$, nTT00%, nRR00%, nCC00%, bRd00 As Boolean)
  11. '===sURL00      為擷取網址
  12. '===nTT00       為讀取第幾個Table(從1開始)
  13. '===nRR00       該Table由第幾列開始讀取(從1開始)
  14. '===nCC00       該Table由第幾欄開始讀取(從1開始)
  15. '===bRd00       該資料是否輸出
  16. Dim nR00%, nC00%, sTemp() As String, oXml As Object, oDoc As Object, oE As Object, tt As Date
  17.     Set oXml = CreateObject("MSXML2.XMLHTTP.6.0")
  18.     Set oDoc = CreateObject("HTMLFile")
  19.     bRd00 = True
  20. rSend:
  21.     tt = Now() + TimeValue("0:00:20")
  22.     With oXml
  23.         .Open "Get", sURL00, True
  24.         .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
  25.         .send
  26.         On Error Resume Next
  27.         Do While .ReadyState <> 4 Or .Status <> 200
  28.             DoEvents
  29.             If Now > tt Then GoTo rSend
  30.         Loop
  31.         On Error GoTo 0
  32.         oDoc.write .responseText
  33.     End With
  34.     If oDoc.all.tags("Table")(nTT00 - 1) Is Nothing Then bRd00 = False: GoTo Err1
  35.     Set oE = oDoc.all.tags("Table")(nTT00 - 1)
  36.     With oE
  37.         ReDim sTemp(.Rows.Length - nRR00, .Rows(nRR00 - 1).Cells.Length - nCC00)
  38.         For nR00 = 0 To .Rows.Length - nRR00
  39.             For nC00 = 0 To .Rows(nR00 + nRR00 - 1).Cells.Length - nCC00
  40.                 sTemp(nR00, nC00) = .Rows(nR00 + nRR00 - 1).Cells(nC00 + nCC00 - 1).innerText
  41.             Next nC00
  42.         Next nR00
  43.     End With
  44. Err1:
  45.     GetWebTb1 = sTemp
  46.     oXml.abort
  47.     oDoc.Close
  48.     Set oXml = Nothing
  49.     Set oDoc = Nothing
  50.     Set oE = Nothing
  51. End Function
複製代碼
作者: Scott090    時間: 2017-6-30 17:59

回復 3# prin.huang


    非常感恩
提供的code 足當一個 sample， 將好好的研讀，不解之處再請益就教

再次的謝謝
作者: GBKEE    時間: 2017-7-1 08:01

  1. Option Explicit
  2. Sub Ex()
  3.     Dim oXmlhttp As Object, oHtmldoc As Object, surl As String, E As Object, R As Integer, C As Integer
  4.     Set oXmlhttp = CreateObject("msxml2.xmlhttp")
  5.     Set oHtmldoc = CreateObject("htmlfile")
  6.     surl = "https://tw.stock.yahoo.com/q/q?s=2330"
  7.         With oXmlhttp
  8.         .Open "Get", surl, False
  9.         .Send
  10.         oHtmldoc.write .responseText
  11.     End With
  12.     ActiveSheet.Cells.Clear
  13.      With oHtmldoc
  14.         Set E = .all.tags("table")(6)
  15.         For R = 0 To E.Rows.Length - 1
  16.             For C = 0 To E.Rows(R).Cells.Length - 1
  17.                 ActiveSheet.Cells(R + 1, C + 1) = E.Rows(R).Cells(C).INNERTEXT
  18.             Next
  19.         Next
  20.         ActiveSheet.Cells(R + 1, 1) = Trim(.all.tags("table")(4).INNERTEXT)
  21.     End With
  22. End Sub
複製代碼
回復 4# Scott090
作者: Scott090    時間: 2017-7-1 09:42

回復 5# GBKEE


    太好了，又得到超級版主的大作
自當好好的研習

感謝
作者: Scott090    時間: 2017-7-1 21:28

回復 3# prin.huang

Sub main() 作修飾如下，請參考
  1. Sub main()
  2. Dim URL$, VV As Boolean, AB() As String

  4. URL = "https://tw.stock.yahoo.com/q/q?s=2330"

  6. 'AB = GetWebTb1(URL, 6, 1, 1, VV)
  7. 'If VV = True Then ActiveSheet.Range("A1") = AB

  9. AB = GetWebTb1(URL, 7, 1, 1, VV)    '目標表格由1開始計算是第7個
  10. If VV = True Then ActiveSheet.Range("A1").Resize(UBound(AB, 1) + 1, UBound(AB, 2) + 1) = AB     'AB陣列放入工作表儲存格

  12. End Sub
複製代碼
作者: prin.huang    時間: 2017-7-4 14:20

回復 7# Scott090

謝啦！從你的code多約會了resize這個用法，好用！
原來我table數錯了，是第七個，不是第六個，
其實我不會數到底是第幾個table，
我是土法煉鋼一個一個輸出，看到底是要那一個table，
結果還是敗在這，不知有沒有較有效率的方法呢？
作者: Scott090    時間: 2017-7-5 08:56

回復 8# prin.huang


    用 QueryTables的方式攫取網頁資料，錄製程式碼，
程式碼內 .WebTables = "7" 就是由1算起排行第7個表格
  1. Sub 巨集1()
  2. '
  3. ' 巨集1 巨集
  4. '

  6. '
  7.     With ActiveSheet.QueryTables.Add(Connection:= _
  8.         "URL;https://tw.stock.yahoo.com/q/q?s=2330", Destination:=Range("$A$1"))
  9.         .Name = "q?s=2330_1"
  10.         .FieldNames = True
  11.         .RowNumbers = False
  12.         .FillAdjacentFormulas = False
  13.         .PreserveFormatting = True
  14.         .RefreshOnFileOpen = False
  15.         .BackgroundQuery = True
  16.         .RefreshStyle = xlInsertDeleteCells
  17.         .SavePassword = False
  18.         .SaveData = True
  19.         .AdjustColumnWidth = True
  20.         .RefreshPeriod = 0
  21.         .WebSelectionType = xlSpecifiedTables
  22.         .WebFormatting = xlWebFormattingNone
  23.         .WebTables = "7"            '顯示所要的資料表格是第7個
  24.         .WebPreFormattedTextToColumns = True
  25.         .WebConsecutiveDelimitersAsOne = True
  26.         .WebSingleBlockTextImport = False
  27.         .WebDisableDateRecognition = False
  28.         .WebDisableRedirections = False
  29.         .Refresh BackgroundQuery:=False
  30.     End With
  31.     ActiveWorkbook.Connections("連線").Delete
  32. End Sub
複製代碼
以上，請參考
謝謝
作者: Scott090    時間: 2017-7-14 08:35

發現這個網站很精彩，主題是：
"ImportXML, GoogleLookup alternatives for Excel"
http://www.ideativi.it/blog/532/importxml_googlelookup_alternatives_for_excel.aspx

內含一個EXCEL檔可供參考：
" •16/09/2013 importxml.1.10.xlsx (first public release)"

以上分享



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)