Board logo

標題: [發問] 股價VBA的檔案無法更新 [打印本頁]
作者: abc9gad2016    時間: 2020-3-31 14:45     標題: 股價VBA的檔案無法更新

本帖最後由 abc9gad2016 於 2020-3-31 14:49 編輯

版上前輩好，自從逐筆交易開始後，我的EXCEL抓取股票即時價就無回應

原本以為是YAHOO STOCK那邊網址有變，所以更新了網址

但結果還是一樣...想請版上高手幫忙看看是什麼原因造成無法更新的 謝謝

[attach]31841[/attach]
PS.此檔案是版主准大所分享的，我只做了一些自己想要的欄位變更  萬分感謝
作者: 准提部林    時間: 2020-3-31 19:14

我的作業環境還是 XP+office 2000
對yahoo及大部份網頁沒輒,
看有否其他大大代為修改程式,
或許傳訊息給超版來看看~~
作者: n7822123    時間: 2020-4-1 00:39

本帖最後由 n7822123 於 2020-4-1 00:51 編輯

回復 1# abc9gad2016

Yahoo可能有改網頁編寫格式

下面程式的ST2的字串在Yahoo網頁原始碼已經找不到了

原程式是用ST1字串與ST2字串擷取一段需要的原始碼資訊~

坦白說，我不大喜歡他解字串的方式......看的很累...........

原程式如下:


Sub 擷取資料()
Dim ReTxt, i&, ARR, BRR(9), V As Currency, GetTime$
uTxtStr = ""
Call 取得網頁原始碼: If uTxtStr = "" Then Exit Sub
'-----------------------------------------------------
GetStr = ""
ST1 = "href=""/q/bc?s=" & uRng & """>"
ST2 = "<a href=""/q/ts?s=" & uRng & """>成交明細</a>"
GetStr = 擷取文字碼(uTxtStr, ST1, ST2):  If GetStr = "" Then Exit Sub


把上面程式的ST2部分，改成如下就可以了

ST2 = "<a href=""/q/ts?s=" & uRng & """>成交彙整</a>"

明細  >>>  彙整



附上我自己做的部分如下 ，舊板Excel不支援超過7層的函數，公式會失效

但是不影響網路抓資料，我抓的網站是Hi投資，我自認寫的檢短多了~應該吧!



[attach]31844[/attach]
作者: abc9gad2016    時間: 2020-4-1 09:37

回復 3# n7822123


   感謝大大分享~另外原版的依照大大所說的變更也能成功抓取了 謝謝
作者: bhsm    時間: 2020-4-1 13:34

回復 3# n7822123
感謝n7822123大的分享
作者: GBKEE    時間: 2020-4-1 16:27

本帖最後由 GBKEE 於 2020-4-1 16:29 編輯

回復 4# abc9gad2016
試試看
  1. Sub 更新全部()
  2.     Call 共用參照: If uRow <= 0 Then Exit Sub
  3.     uHead(0, 0) = "※更新中.............."
  4.     uHead(2, 12).Resize(uRow).ClearContents
  5.     For Each uRng In uClmnNo
  6.         uRng(1, 3).Resize(1, 10).ClearContents
  7.         網頁元素_htmlfile uRng
  8.         Beep
  9.     Next
  10.     uHead(0, 0) = "※更新時間：" & Format(Now, "yyyy/mm/dd hh:mm:ss")
  11.     ThisWorkbook.Save
  12. End Sub

  14. Sub 網頁元素_htmlfile(uRng As Range)
  15.     Dim oXmlhttp As Object, oHtmldoc As Object, surl As String, E As Object, i As Integer
  16.     Set oXmlhttp = CreateObject("msxml2.xmlhttp")
  17.     Set oHtmldoc = CreateObject("htmlfile")
  18.    If uRng = "" Then Exit Sub
  19.     surl = "https://tw.stock.yahoo.com/q/q?s=" & uRng
  20.     With oXmlhttp
  21.         .Open "Get", surl, False
  22.         .Send
  23.         oHtmldoc.write .responseText
  24.     End With
  25.     On Error GoTo Ne    '處理股票代碼不存在時程式的出錯
  26.      With oHtmldoc
  27.         Set E = .all.tags("TABLE")(2).Rows(1).Cells  '股票代碼不存時  E Is Nothing
  28.         '** .Rows(1).Cells 網頁表格的內容 ****
  29.         uRng.Cells(1, 2) = Split(E(0).INNERTEXT, vbCrLf)(0)     '去掉換行後的字元
  30.         uRng.Cells(1, 2) = Replace(uRng.Cells(1, 2), uRng, "") '消除股票代碼
  31.         For i = 2 To E.Length - 2
  32.                If i = 2 + 3 Then
  33.                     uRng.Cells(1, i + 1) = Mid(E(i).INNERTEXT, 2) '**消除漲跌的符號**
  34.                 Else
  35.                     uRng.Cells(1, i + 1) = E(i).INNERTEXT
  36.                 End If
  37.         Next
  38.         uRng.Cells(1, i + 1) = E(1).INNERTEXT  '交易時間
  39.     End With
  40. Ne:
  41.   uRng.Interior.Color = IIf(E Is Nothing, vbRed, xlAutomatic) '
  42.     Set oXmlhttp = Nothing  '
  43.     Set oHtmldoc = Nothing
  44. End Sub
複製代碼
作者: imingho    時間: 2020-4-2 15:53

回復 1# abc9gad2016

附檔是我修改過的檔案，可以下載試看看。
[attach]31854[/attach]



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