股價VBA的檔案無法更新 - Excel程式區

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2020-4-1 16:27 | 顯示全部帖子

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

回復 4# abc9gad2016
試試看

Sub 更新全部()
Call 共用參照: If uRow <= 0 Then Exit Sub
uHead(0, 0) = "※更新中.............."
uHead(2, 12).Resize(uRow).ClearContents
For Each uRng In uClmnNo
uRng(1, 3).Resize(1, 10).ClearContents
網頁元素_htmlfile uRng
Beep
Next
uHead(0, 0) = "※更新時間：" & Format(Now, "yyyy/mm/dd hh:mm:ss")
ThisWorkbook.Save
End Sub
Sub 網頁元素_htmlfile(uRng As Range)
Dim oXmlhttp As Object, oHtmldoc As Object, surl As String, E As Object, i As Integer
Set oXmlhttp = CreateObject("msxml2.xmlhttp")
Set oHtmldoc = CreateObject("htmlfile")
If uRng = "" Then Exit Sub
surl = "https://tw.stock.yahoo.com/q/q?s=" & uRng
With oXmlhttp
.Open "Get", surl, False
.Send
oHtmldoc.write .responseText
End With
On Error GoTo Ne '處理股票代碼不存在時程式的出錯
With oHtmldoc
Set E = .all.tags("TABLE")(2).Rows(1).Cells '股票代碼不存時 E Is Nothing
'** .Rows(1).Cells 網頁表格的內容 ****
uRng.Cells(1, 2) = Split(E(0).INNERTEXT, vbCrLf)(0) '去掉換行後的字元
uRng.Cells(1, 2) = Replace(uRng.Cells(1, 2), uRng, "") '消除股票代碼
For i = 2 To E.Length - 2
If i = 2 + 3 Then
uRng.Cells(1, i + 1) = Mid(E(i).INNERTEXT, 2) '**消除漲跌的符號**
Else
uRng.Cells(1, i + 1) = E(i).INNERTEXT
End If
Next
uRng.Cells(1, i + 1) = E(1).INNERTEXT '交易時間
End With
Ne:
uRng.Interior.Color = IIf(E Is Nothing, vbRed, xlAutomatic) '
Set oXmlhttp = Nothing '
Set oHtmldoc = Nothing
End Sub

複製代碼

1 評分人數

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

靜思自在 : 做該做的事是智慧，做不該做的事是愚癡。