今有一陣列公式 A2~F101
用迴圈依序執行AD2~AD31的代號
可得陣列計算後的數值
欄位 AE1的數值為陣列計算後, B101的數值
欄位 AF1的數值為陣列計算後, E101的數值
當執行完AD2的代號, 將AE1記錄在AE2, 將AF1記錄在AF2
當執行完AD3的代號, 將AE1記錄在AE3, 將AF1記錄在AF3
當執行完AD4的代號, 將AE1記錄在AE4, 將AF1記錄在AF4
....依此類推,記錄到AE31, AF31
目前遇到的問題是, AE, AF欄位有些數字, 有些卻沒記錄數字, 不知道是哪裡出問題?
請各位大神幫忙, 感激不盡
以下為我的VBA程式
= = = = = = = = = = = = = = = = = = = = = =
Sub 一鍵更新()
'先關閉螢幕更新(最後再開啟,會更新得快一點)
Application.ScreenUpdating = False
For i = 2 To 31
'代號
CCode = Sheets("Data").Cells(i, "AD")
'更新且計算公式陣列
Sheets("Data").Range("A2:F101").FormulaArray = "=XQLITE|Kline!'" & CCode & ".TW-Day-100'"
'複製計算後的數據,並依代號, 貼到相對應的位置
Range("AE1:AF1").Select
Selection.Copy
Range("AE" & i & ":AF" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next i
End Sub
昨天開始就全部抓不到,之前是一直會有幾檔抓不到,要持續抓好幾次才會抓齊。
目前用的是底下這個routine,把重試次數設很大也是抓不到資料…
Sub getstock(firstdata, lastdata, lastrow)
Dim Url, HTMLsourcecode, GetXml
Dim Stock As String
For k = firstdata To lastdata
Stock = Sheets("TW.Stock").Cells(k, 1)
quotelen = Len(Stock)
DoEvents
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Url = "https://tw.stock.yahoo.com/q/q?s=" & Sheets("TW.Stock").Cells(k, 1)
retry:
Set Html = CreateObject("htmlfile")
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
With GetXml
.Open "GET", Url, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
Html.body.innerhtml = .responsetext
Debug.Print Html.All.tags("table").Length
If Html.All.tags("table").Length = 0 Then
re = re + 1
Debug.Print "retry:" & re
If re > 5 Then
ActiveSheet.Cells(1, 1) = "下載失敗"
Exit Sub
End If
Delaytick (0.5)
Set Html = Nothing
Set GetXml = Nothing
GoTo retry
End If
Set Table = Html.All.tags("table")(2).Rows
蔬食抗暖化,減碳救地球!
目前是改成2021-06-08 1:30 1024樓,yahoo 範例的格式,猜測現在接近最終版
原理可去1024樓看,這裡不多做說明
(1024樓,因yahoo改版,range("b1")字串要重新整理)
(會的請自行修改,直接不要b1也行,其它下載功能都正常,有空我再改)
有人知道舊版的“張數”是對應新版網頁中的那一格嗎?
(經nijawang指導,張數問題已解決)
https://tw.stock.yahoo.com/q/q?s=2330
範例中的排版方式,維持舊版
避免有人用這個格式寫程式、公式,排版一變,那全部要重寫,很麻煩的
'程式碼放到模組裡
'暫時用on error resume next 做個簡單除錯,因為不知道網頁會不會再改
'各筆之間的下載時間延遲(Delaytick),好像可以不用,有需要請自行啟用
'fake_Multiplex() 副程式,也可改用1098樓寫法替換,不影響功能有興趣自行替換
Global DownloadError As Integer
Sub fake_Multiplex()
Dim i As Integer, j As Integer, LastRow As Integer, Firstdata As Integer, Lastdata As Integer, t As Double, ErrorStock As Integer
t = Timer
DownloadError = 0
LastRow = Sheets("stock").Range("a1").CurrentRegion.Rows.Count
Sheets("stock").Range("b2:l" & LastRow).Clear: Sheets("stock").Range("n1:n3") = ""
If LastRow Mod 5 > 0 Then j = Int(LastRow / 5) + 1 Else j = Int(LastRow / 5)
For i = 1 To j
DoEvents
If i = 1 Then Firstdata = 2 Else Firstdata = (i - 1) * 5 + 1
If i = j Then
Lastdata = LastRow
Else
Lastdata = (i - 1) * 5 + 5
End If
'修正nijawang 1097樓,發現的一個小bug,請自行修改附件中的程式碼
Sheets("stock").Range("n1") = "Loading " & Round((i / j) * 100) & "%"
Call getstock(Firstdata, Lastdata)
Next i
With Sheets("stock")
If DownloadError > 0 Then Call Redownload
If DownloadError > 0 Then .Range("n2") = DownloadError & " 下載失敗"
.Range("n1") = LastRow - 1 - DownloadError & " stock loading ok"
.Cells.EntireColumn.AutoFit
End With
Debug.Print Timer - t
End Sub
Sub Redownload()
If DownloadError = 0 Then Exit Sub
Dim i As Integer, LastRow As Integer
LastRow = Sheets("stock").Range("a1").CurrentRegion.Rows.Count
For i = 5 To 0 Step -1
Delaytick (1)
Sheets("stock").Range("n3") = DownloadError & "筆失敗=>" & i & "秒後,重新下載"
Next i
DownloadError = 0
Sheets("stock").Range("n3") = ""
For i = 2 To LastRow
If Sheets("stock").Cells(i, 2) = "下載失敗" Then
Sheets("stock").Cells(i, 2) = ""
Call getstock(i, i)
End If
Next i
End Sub
Sub getstock(Firstdata As Integer, Lastdata As Integer)
Dim URL As String, GetXml As Object, Jsondata As Object, DecodeJson, temp As String, DataTime As String, i As Integer, j As Integer, k As Integer
On Error Resume Next
For k = Firstdata To Lastdata
DoEvents
URL = "https://tw.stock.yahoo.com/q/q?s=" & Sheets("stock").Cells(k, 1)
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
Set Jsondata = CreateObject("HtmlFile")
With GetXml
.Open "GET", URL, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
DataTime = Split(Split(.responsetext, "datatime=""")(1), """>")(0)
'(20210917,縮短split判斷用字串,避免部份格式不同的代碼無法下載)
temp = "{""quote"":{""data"":" & Split(Split(.responsetext, """quote"":{""data"":")(1), ",""orderbook"":")(0) & "}}}"
Set DecodeJson = CallByName(CallByName(Jsondata.JsonParse(temp), "quote", VbGet), "data", VbGet)
With Sheets("stock")
.Cells(k, 2) = CallByName(DecodeJson, "symbolName", VbGet)
.Cells(k, 3) = DataTime 'CallByName(DecodeJson, "regularMarketTime", VbGet)
.Cells(k, 4) = CallByName(DecodeJson, "price", VbGet)
.Cells(k, 5) = CallByName(DecodeJson, "bid", VbGet)
.Cells(k, 6) = CallByName(DecodeJson, "ask", VbGet)
.Cells(k, 7) = CallByName(DecodeJson, "changePercent", VbGet)
If .Cells(k, 7).Value > 0 Then .Cells(k, 7).Font.Color = -16776961 _
Else If .Cells(k, 7).Value < 0 Then .Cells(k, 7).Font.Color = -11489280
'.Cells(k, 8) ' i don't know
'(經nijawang指導,這行修正如下)
.Cells(k, 8) = CallByName(DecodeJson, "volume", VbGet)/1000
.Cells(k, 9) = CallByName(DecodeJson, "regularMarketPreviousClose", VbGet)
.Cells(k, 10) = CallByName(DecodeJson, "regularMarketOpen", VbGet)
.Cells(k, 11) = CallByName(DecodeJson, "regularMarketDayHigh", VbGet)
.Cells(k, 12) = CallByName(DecodeJson, "regularMarketDayLow", VbGet)
If .Cells(k, 2) = "" Then
.Cells(k, 2) = "下載失敗"
DownloadError = DownloadError + 1
End If
End With
End With
Set GetXml = Nothing
Set Jsondata = Nothing
Set DecodeJson = Nothing
'Delaytick (0.3)
Next k
End Sub
Sub Delaytick(setdelay As Single)
Dim StartTime As Double, NowTime As Double
StartTime = Timer * 100
setdelay = setdelay * 100
Do
NowTime = Timer * 100
DoEvents
Loop Until NowTime - StartTime > setdelay
End Sub
(經nijawang指導,張數問題已解決)
請自行修改附件中的程式碼
'.Cells(k, 8) ' i don't know
改成
.Cells(k, 8) = CallByName(DecodeJson, "volume", VbGet)/1000
如果有人想要用舊版的▲漲、▼跌,代替正負號
把這行
If .Cells(k, 7).Value > 0 Then .Cells(k, 7).Font.Color = -16776961 _
Else If .Cells(k, 7).Value < 0 Then .Cells(k, 7).Font.Color = -11489280
換成下面這幾行
'debug.print vartype(CallByName(DecodeJson, "changePercent", VbGet)) ' 8 = string
Dim changePercent As Double
changePercent = .Cells(k, 7)
If changePercent > 0 Then
.Cells(k, 7).Value = "▲" & changePercent * 100 & "%"
.Cells(k, 7).Font.Color = -16776961
ElseIf changePercent < 0 Then
.Cells(k, 7).Value = Replace(changePercent * 100, "-", "▼") & "%"
.Cells(k, 7).Font.Color = -11489280
End If
(20231215 網頁改版,請參考1364樓nijawang提出的修改方式,自行更新程式碼)
[點擊下載]
延續我前面的留言。
之前我用舊版VBA,同樣以代碼^TWII從台灣Yahoo!抓大盤指數沒有問題。
因為網頁格式是一樣的。
至於新版Yahoo!,我比較了一下網頁格式,股票跟大盤也是一樣。
https://tw.stock.yahoo.com/q/q?s=2330
https://tw.stock.yahoo.com/q/q?s=^TWII
看了網頁原始碼,好像也差不多。
我再找時間處理看看。
謝謝!
蔬食抗暖化,減碳救地球!
nijawang wrote:
在O1上的下載%,最後會停留在91%,但因為馬上被50 stock蓋過去,所以看不到…
底下這一行code好像應該要放在End If之後,才會在最後顯示100%。
測試後確實發現有這個bug…,不重要,無視
會拆那麼多份,是因為以前舊版excel,這樣寫可以增加一點點效率、穩定性
所以副程式才會取名為 fake_Multiplex => 假多工
改版後的yahoo,json資料為主,不用這樣寫了,穩定性也相當好
fake_Multiplex()
可以改成這樣,從第一筆跑到最後一筆就行,程式碼也比較短
不用拆的亂七八糟,百分比數字跳的也比較好看
有興趣可以自行替換
Sub fake_Multiplex()
Dim i As Integer, LastRow As Integer, t As Double
t = Timer
DownloadError = 0
LastRow = Sheets("stock").Range("a1").CurrentRegion.Rows.Count
Sheets("stock").Range("b2:l" & LastRow).Clear: Sheets("stock").Range("n1:n3") = ""
For i = 2 To LastRow
DoEvents
Sheets("stock").Range("n1") = "Loading " & Round((i / LastRow) * 100) & "%"
Call getstock(i, i)
Next i
With Sheets("stock")
If DownloadError > 0 Then Call Redownload
If DownloadError > 0 Then .Range("n2") = DownloadError & " 下載失敗"
.Range("n1") = LastRow - 1 - DownloadError & " stock loading ok"
.Cells.EntireColumn.AutoFit
End With
Debug.Print Timer - t
End Sub
有關Yahoo股利分配查詢的頁面已完全改版,使用您提供的新版股票查詢程式,並自行修改部分程式碼,作為股利查詢,但執行過程,一直出現錯誤訊息,實在解決不了,上線請樓主撥空看看,應如何修正?
部分程式碼:
DoEvents
URL = "https://tw.stock.yahoo.com/d/s/dividend_6206.html"
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
Set Jsondata = CreateObject("HtmlFile")
With GetXml
.Open "GET", URL, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
dtemp = "{""QuoteDividendStore"":{""dividend"":{""data"":[" & Split(Split(.responsetext, """QuoteDividendStore"":{""dividend"":{""data"":[")(1), ",""WaferMarketTimeStore"":")(0)
Set DecodeJson = CallByName(CallByName(Jsondata.JsonParse(dtemp), "dividend", VbGet), "data", VbGet)
Debug.Print dtemp
錯誤訊息:
activer wrote:
有關Yahoo股利分配查詢的頁面已完全改版,使用您提供的新版股票查詢程式
前幾個月,因為yahoo瘋狂改版,做了很多沒po的範例
剛好其中一個clipboard版的範例就是這個,先參考這個...
(您json下載錯誤修正方式,請看文末的補充說明後,再自行修正)
Sub Get_Yahoo_dividend_clipboard()
Dim html As Object, Table, Clipboard As Object, xmlHttp As Object, URL As String, Original_Data As Range, LastRow As Integer, Stock As String, ttt As Double
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Set html = CreateObject("htmlfile")
ttt = Timer
'Stock = "2412" 'test
Stock = "2002" 'test
'Stock = "2330" 'test
URL = "https://tw.stock.yahoo.com/quote/" & Stock & "/dividend"
Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
With xmlHttp
.Open "GET", URL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.send
End With
Set Table = html.getElementById("main-2-QuoteDividend-Proxy")
Clipboard.SetText Table.innerText
Clipboard.PutInClipboard
Application.ScreenUpdating = False
With Sheets("工作表1")
.Select
.Cells.Clear
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=False
.Range("a1:a5").Delete Shift:=xlUp
Set Original_Data = .Range("a3")
LastRow = 2 '0 to n
Do Until Original_Data.Value = ""
LastRow = LastRow + 1
Original_Data.Resize(6).Copy
.Range("B" & LastRow).PasteSpecial Transpose:=True
Set Original_Data = Original_Data.Offset(6)
Loop
.Range("b1:b2").Value = .Range("a1:a2").Value
.Range("b1").Value = "(" & Stock & ")" & .Range("b1").Value
.Columns("A:A").Delete Shift:=xlToLeft
.Cells.ColumnWidth = 16
End With
Debug.Print Timer - ttt
Application.ScreenUpdating = True
Set xmlHttp = Nothing
Set Clipboard = Nothing
Set Table = Nothing
Set html = Nothing
End Sub
activer wrote:
但執行過程,一直出現錯誤訊息
會錯誤是因為,json沒有做成正確格式
temp = "{""QuoteDividendStore"":{""dividend"":{""data"":[" & Split(Split(.responsetext, """QuoteDividendStore"":{""dividend"":{""data"":[")(1), ",""WaferMarketTimeStore"":")(0) & "}"
Set DecodeJson = CallByName(CallByName(CallByName(Jsondata.JsonParse(temp), "QuoteDividendStore", VbGet), "dividend", VbGet), "data", VbGet)
'接下來就一層一層拆出想要的資料
'最近可參考的json拆解範例是1053樓
For i = 0 To CallByName(DecodeJson, "length", VbGet) - 1
set ...
....
....
Next i
關閉廣告