返回列表 上一主題 發帖

[發問] 股價VBA的檔案無法更新

[發問] 股價VBA的檔案無法更新

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

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

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

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

股VBA.rar (39.08 KB)
PS.此檔案是版主准大所分享的,我只做了一些自己想要的欄位變更  萬分感謝

我的作業環境還是 XP+office 2000
對yahoo及大部份網頁沒輒,
看有否其他大大代為修改程式,
或許傳訊息給超版來看看~~
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

本帖最後由 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投資,我自認寫的檢短多了~應該吧!



理財策略V1.0.rar (91.56 KB)
1

評分人數

程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

回復 3# n7822123


   感謝大大分享~另外原版的依照大大所說的變更也能成功抓取了 謝謝

TOP

回復 3# n7822123
感謝n7822123大的分享
年齡不小,但我很想學

TOP

本帖最後由 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

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

評分人數

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 1# abc9gad2016

附檔是我修改過的檔案,可以下載試看看。
_金千里股票監看系統.zip (31.9 KB)
1

評分人數

參考資料:
http://bestdaylong.com

TOP

        靜思自在 : 心中常存善解、包容、感思、知足、惜福。
返回列表 上一主題