(不定期更新)使用VBA解決 excel web 查詢無法匯入、匯入太慢的股市資料

nijawang wrote:
請問yahoo的舊版股價VBA是不是完全抓不到資料了？
(恕刪)

'程式碼放到模組裡
'暫時用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

如果有人想要用舊版的▲漲、▼跌，代替正負號



把這行

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

nijawang wrote:
在O1上的下載%，最後會停留在91%，但因為馬上被50 stock蓋過去，所以看不到…
底下這一行code好像應該要放在End If之後，才會在最後顯示100%。

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

activer wrote:
有關Yahoo股利分配查詢的頁面已完全改版,使用您提供的新版股票查詢程式

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:
但執行過程,一直出現錯誤訊息