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

smart3135 wrote:
抓資料的網頁從IE切換到Chrome，語法該如何修正，是否有範例可參考呢？再麻煩您撥空指導一下，感謝。

'chrome開啟yahoo 首頁，輸入=>按搜尋，簡易範例
'(需安裝Selenium)










Sub test()

    Dim chrome As New Selenium.ChromeDriver, UrL As String, s  As String
    
    UrL = "https://tw.yahoo.com/"
    s = "mobile01"
    
    With chrome
        .Get UrL
    
        '.Window.Maximize
        '.Wait 5000
        
        .FindElementById("header-search-input").SendKeys (s)
        .FindElementById("header-desktop-search-button").Click
    
    End With
        
    Stop
        
    chrome.Quit
    Set chrome = Nothing
    
End Sub

snare wrote:
因為您的問題是無法公(恕刪)

smart3135 wrote:
或是有什麼相關書籍可以推薦？

smart3135 wrote:
只是這種語法教學是否有關鍵字可以google搜尋？

smart3135 wrote:
因我用google搜尋了很多諸如"VBA控制chrome、VBA操作網頁輸入查詢"等之類的，都找不到相關資料

smart3135 wrote:
另外有用您提供的範例依樣畫葫蘆用蝦皮操作一次，但卻出錯，可否再請您幫忙看一下是哪裡寫錯呢？

Sub test()

    Dim chrome As New Selenium.ChromeDriver, UrL As String, s  As String
    
    UrL = "https://shopee.tw/"
    s = "玩具"
    
    With chrome
        .Get UrL
    
        .FindElementByXPath("/html").Click  '        .FindElementById("main").Click
        
        '.FindElementByClass("shopee-searchbar-input__input").SendKeys (s)
        .FindElementByXPath("//*[@id='main']/div/div[2]/div[1]/div/div[2]/div/div[2]/div/header/div[2]/div/div[1]/div[1]/div/form/input").SendKeys (s)
        .FindElementByXPath("//*[@id='main']/div/div[2]/div[1]/div/div[2]/div/div[2]/div/header/div[2]/div/div[1]/div[1]/button").Click
        
    End With
        
    Stop
        
    chrome.Quit
    Set chrome = Nothing
    
End Sub

snare wrote:
不知道，沒在看書的，(恕刪)

smart3135 wrote:
可否提點一下這個FindElement該怎麼寫呢？

Sub test()
    
    Dim chrome As New Selenium.ChromeDriver, UrL As String, s  As String
    
    UrL = "https://www.google.com.tw/"
    s = "mobile01" & Chr(10)
        
    With chrome
        .Get UrL
        '.FindElementByXPath("/html/body/div[1]/div[3]/form/div[1]/div[1]/div[1]/div/div[2]/input").SendKeys (s)
        .FindElementByName("q").SendKeys (s)
    End With
     
    Stop
    
    chrome.Quit
    Set chrome = Nothing
    
End Sub

Sub Get_tdcc()
    
    
    Dim Html As Object, GetXml As Object, r As Integer, url_a As String, temp() As String, ttt As Double
    Dim SYNCHRONIZER_TOKEN As String, firDate As String, StockID As String, StockName As String
    Set Html = CreateObject("htmlfile")
    Set GetXml = CreateObject("msxml2.xmlhttp")
    
    
    ttt = Timer
    Application.ScreenUpdating = False
    
    
    'StockID = "2002"
    StockID = "2330"
    
    
retry2:
    
    On Error GoTo redownload
           
           
    With GetXml
        .Open "GET", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
        .send
        
        Html.body.innerhtml = .responsetext
        SYNCHRONIZER_TOKEN = Html.getElementById("SYNCHRONIZER_TOKEN").Value
        firDate = Html.getElementById("scaDate")(0).innertext
        
    End With
           
           
         
    url_a = "SYNCHRONIZER_TOKEN=" & SYNCHRONIZER_TOKEN & "&SYNCHRONIZER_URI=%2Fportal%2Fzh%2FsmWeb%2FqryStock&method=submit&firDate=" & firDate & "&scaDate=" & firDate & "&sqlMethod=StockNo&stockNo=" & StockID & "&stockName="
        
    With GetXml
        .Open "POST", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", "https://www.tdcc.com.tw/portal/zh/smWeb/qryStock"
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:102.0) Gecko/20100101 Firefox/102.0"
        .send (url_a)
            
        Html.body.innerhtml = .responsetext
        
        'debug(因語法衝突，以下2行改用圖片代替)


                
                
        Set Table = Html.all.tags("table")(1).Rows
            
        If Table(1).Cells(0).innertext = "查無此資料" Then
            Delaytick (0.3)
            r = r + 1
            If r > 5 Then
                MsgBox StockID & vbNewLine & firDate & "，此日期無資料或連線異常，請稍後再試", vbOKOnly, "Error"
                Set Table = Nothing
                Set Html = Nothing
                Set GetXml = Nothing
                Application.ScreenUpdating = True
                Exit Sub
            End If
            GoTo retry2
        End If
            
                
        ReDim temp(1 To Table.Length - 1, Table(2).Cells.Length - 1)
                
        With Sheets("工作表1")
            .Cells.Clear
            
            For i = 1 To Table.Length - 1
                    
                For j = 0 To Table(i).Cells.Length - 1
                    temp(i, j) = Table(i).Cells(j).innertext
                Next j
            Next i
            
            .Range("a1") = firDate         'debug
            .Range("a2") = StockName 'debug
            .Range("c3:g3") = Array("序", "持股", "人數", "股數", "比例%")
            .Range(.Cells(4, 3), .Cells(i + 2, 7)) = temp()
            .Columns.AutoFit
            
        End With

    End With
    
    
    
    Set Table = Nothing
    Set Html = Nothing
    Set GetXml = Nothing
    Application.ScreenUpdating = True
    
    Debug.Print Timer - ttt
    Exit Sub
    
redownload:
    r = r + 1
    Debug.Print "http 404"
    Delaytick (1.3)
    If r > 3 Then
       MsgBox "連線異常，請稍後再試", vbOKOnly, "Error"
       
       'Stop 'debug
       
       Set Table = Nothing
       Set Html = Nothing
       Set GetXml = Nothing
       Application.ScreenUpdating = True
       Exit Sub
    
    End If
    
    If Err.Number <> 0 Then
        Debug.Print Err.Description
    End If
    
    On Error GoTo -1
    Err.Clear
    
    GoTo retry2


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 wrote:
那是不是變成只能用抓關鍵字來取得報價？
不過好像也不能用原本的GetXml方式了。

Sub Get_Yahoo_vti_text()

    Dim UrL As String, GetXml As Object, Price As String, ttt As Double
    Set GetXml = CreateObject("msxml2.xmlhttp")

    ttt = Timer
    UrL = "https://tw.stock.yahoo.com/quote/vti"

    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
        
        Price = Split(Split(.responsetext, """previousVolume"":null,""price"":""")(1), """,""regularMarketDayHigh""")(0)
       
    End With
    
    'debug
    MsgBox "成交  " & Price & vbNewLine & Timer - ttt & "s", vbOKOnly, "report"
        
    Set GetXml = Nothing
    
End Sub

nijawang wrote:
今天Yahoo!的美股報價好像把table拿掉，換成flex屬性。
https://tw.stock.yahoo.com/quote/vti

'只要表格資料







Sub Get_Yahoo_vti_Json_1()

    Dim UrL As String, GetXml As Object, Jsondata As Object, DecodeJson, ttt As Double
    
    Set GetXml = CreateObject("msxml2.xmlhttp")
    Set Jsondata = CreateObject("HtmlFile")





    ttt = Timer
        
    UrL = "https://tw.stock.yahoo.com/quote/vti"


    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
            
             
        Set DecodeJson = CallByName(Jsondata.JsonParse("{""data"":" & Split(Split(.responsetext, """quote"":{""data"":")(1), ",""isFailed"":")(0) & "}"), "data", VbGet)
       
    End With
    
    '========================
    'json整理用程式碼放這裡
    
    'debug
    MsgBox "成交  " & CallByName(DecodeJson, "price", VbGet) & vbNewLine & Timer - ttt & "s", vbOKOnly, "report"
    
    '========================
        
    Set GetXml = Nothing
    Set Jsondata = Nothing
    Set DecodeJson = Nothing
    
End Sub

'表格、含圖表原始資料






Sub Get_Yahoo_vti_Json_2()

    Dim UrL As String, GetXml As Object, Jsondata As Object, DecodeJson, ttt As Double
    
    
    ttt = Timer
    
     
    Set GetXml = CreateObject("msxml2.xmlhttp")
    Set Jsondata = CreateObject("HtmlFile")
    
    


 

    '當日
    UrL = "https://tw.stock.yahoo.com/_td-stock/api/resource/FinanceChartService.ApacLibraCharts;autoRefresh=" & UNIXTime & ";period=1m;range=1d;symbols=[""VTI""];type=null?bkt=&device=desktop&ecma=modern&feature=ecmaModern,useVersionSwitch,useNewQuoteTabColor&intl=tw⟪=zh-Hant-TW&partner=none&prid=7c6hs39hdihpb®ion=TW&site=finance&tz=Asia/Taipei&ver=1.2.1415&returnMeta=true"
    '5天
    'UrL = "https://tw.stock.yahoo.com/_td-stock/api/resource/FinanceChartService.ApacLibraCharts;autoRefresh=" & unixtime & ";period=15m;range=5d;symbols=[""VTI""];type=null?bkt=&device=desktop&ecma=modern&feature=ecmaModern,useVersionSwitch,useNewQuoteTabColor&intl=tw⟪=zh-Hant-TW&partner=none&prid=7c6hs39hdihpb®ion=TW&site=finance&tz=Asia/Taipei&ver=1.2.1415&returnMeta=true"
    

    With GetXml
    
        .Open "GET", UrL, False
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "Referer", "https://tw.stock.yahoo.com/quote/vti"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
            
             
        Set DecodeJson = CallByName(CallByName(CallByName(Jsondata.JsonParse(.responsetext), "data", VbGet), "0", VbGet), "chart", VbGet)
       
    End With
    

    '========================
    'json整理用程式碼放這裡
    'debug
    MsgBox CallByName(CallByName(DecodeJson, "meta", VbGet), "symbol", VbGet)
    
    '========================
    
    Set GetXml = Nothing
    Set Jsondata = Nothing
    Set DecodeJson = Nothing
    
End Sub


Function UNIXTime()
UNIXTime = Round(((Date - #1/1/1970#) * 86400 + Timer) * 1000, 0)
End Function