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

tmwcykixe wrote:
https://www.cmoney.tw/finance/f00026.aspx?s=6706,這網頁內的資料應參考那個範例抓取或需使用其他方法呢?(恕刪)

'範例只示範下載"基本資料"這一頁，2部份資料各取2筆



Sub GET_cmoney_json()

    Dim Xmlhttp As Object, Url As String, Url_a As String, Url_b As String, Url_c As String, cmkey As String, stock As String
    Dim Jsondata As Object, Json, temp

    Set Jsondata = CreateObject("HtmlFile")
Jsondata.write ”＜script＞document.JsonParse＝function （s） ｛return eval（’（’ ＋ s ＋ ’）’）；｝＜／script＞”
'jsondata.write 這行是全形字，請自行改成半形，或直接用檔案中的程式碼

    Sheets("工作表1").Cells.Clear
    
    stock = InputBox("股票代號", , "6706")
    If stock = "" Then Exit Sub
    
    Url = "https://www.cmoney.tw/finance/f00026.aspx?s=" & stock
    
    Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    With Xmlhttp
    
       .Open "GET", Url, False
       .send
       
        cmkey = Split(Split(.responsetext, "title='基本資料' cmkey='")(1), "'>基本資料<")(0)
        cmkey = UrlEncode(cmkey)

        Url_a = "https://www.cmoney.tw/finance/ashx/mainpage.ashx?action=GetStockListLatestSaleData&stockId=" & stock & "&cmkey=" & cmkey & "&_=" & UNIXTime
       .Open "GET", Url_a, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Referer", Url
       .send
        
        Set Json = Jsondata.JsonParse(.responsetext)
        
        Cells(1, 1) = "股價" & CallByName(CallByName(Json, "commSaleData", VbGet), "SalePr", VbGet)
        Cells(2, 1) = "股本(百萬)" & CallByName(CallByName(Json, "companyInfo", VbGet), "Capital", VbGet)
        '================
        
        '其它資料請自行用callbyname取出


        
        '================
        
        
        Url_b = "https://www.cmoney.tw/finance/ashx/mainpage.ashx?action=GetStockBasicInfo&stockId=" & stock & "&cmkey=" & cmkey
       .Open "GET", Url_b, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Referer", Url
       .send
       
       Set Json = Jsondata.JsonParse(Replace(Replace(.responsetext, "[", ""), "]", ""))
    
       Cells(5, 1) = "單月營收年成長率：" & CallByName(Json, "MonthlyRevenueYearGrowth", VbGet)
       Cells(6, 1) = "股價淨值比：" & CallByName(Json, "PBR", VbGet)
       
       
        '================
        
        '其它資料請自行用callbyname取出

        

        '================
        
       
       
    End With
    
    
    Set Xmlhttp = Nothing
    Set Json = Nothing
    Set temp = Nothing
    
End Sub


Function UNIXTime()

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

End Function
'以下function因論譠語法關係，無法正常顯示，改用圖片，或參考附檔

Sub Test()
        
    Dim IE As Object, Url As String, table, i As Integer, j As Integer, temp
    
    ActiveSheet.Cells.Clear
    Application.ScreenUpdating = False
     
    Set IE = CreateObject("InternetExplorer.Application")
    Url = "https://www.cmoney.tw/finance/f00026.aspx?s=6706"
    
    With IE
        .Visible = True
        .Navigate Url
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
        
        Application.Wait (Now + TimeValue("0:00:5"))
        
        Set table = .document.getelementsbytagname("table")(0).Rows
        For i = 0 To table.Length - 1
            For j = 0 To table(i).Cells.Length - 1
                ActiveSheet.Cells(i + 1, j + 1) = table(i).Cells(j).innertext
            Next j
        Next i
        
        Set table = .document.GetElementByID("HeaderContent")
        temp = Split(table.innertext, vbNewLine)
        For i = 0 To UBound(temp)
           ActiveSheet.Cells(20 + i, 1) = temp(i)
        Next i
        
        ActiveSheet.Cells.Columns.AutoFit
        
    End With
    
    IE.Quit
    Set IE = Nothing
    Set table = Nothing
        
    Application.ScreenUpdating = True
        
End Sub

tmwcykixe wrote:
但為什麼po到瀏覽器或者使用postman這軟體(Content-Type及Referer都有設)來試，仍是會出現{"Error":-3,"Message":"金鑰不正確"}，用vba卻抓得到資料?(恕刪)

tmwcykixe wrote:
https://www.rocketfinancial.com/Financials.aspx?fID=4614&pw=152220
這網址是如何取得？以利該網頁內資料的取得。(恕刪)

'a欄13碼數字，請自行轉成日期，可回頭找其它範例，或 google unixtime 用函數處理
Sub GET_rocketfinancial_json()

    Dim Xmlhttp As Object, URL As String, Url_a As String, stock As String, PostJson As String, code As String
    Dim Jsondata As Object, Json, temp

    Set Jsondata = CreateObject("HtmlFile")
    Jsondata.write ”＜script＞document.JsonParse＝function （s） ｛return eval（’（’ ＋ s ＋ ’）’）；｝＜／script＞”
'jsondata.write 這行是全形字，請自行改成半形


    Sheets("工作表1").Cells.Clear
    
    stock = "aapl"
   
        
    URL = "https://www.rocketfinancial.com/"
    Url_a = "https://www.rocketfinancial.com/WebService.asmx/SearchForFiler"
    PostJson = "{""prefixText"":""" & stock & """,""count"":9}"
    
    
    Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    With Xmlhttp
    
       .Open "POST", Url_a, False
       .setRequestHeader "Content-type", "application/json"
       .setRequestHeader "Accept", "application/json"
       .setRequestHeader "Referer", URL
       .send PostJson
       
        Set Json = Jsondata.JsonParse(.responsetext)
        Set Json = Jsondata.JsonParse(CallByName(Json, "d", VbGet))
        code = CallByName(Json, "Second", VbGet)
        
        URL = "https://www.rocketfinancial.com/Overview.aspx/GetData"
        Url_a = "https://www.rocketfinancial.com/Overview.aspx?fID=" & code & "&pw=152220"
        PostJson = "{ 'fID': '" & code & "', 'range': '730' }"
    
       .Open "POST", URL, False
       .setRequestHeader "Content-type", "application/json"
       .setRequestHeader "Accept", "application/json"
       .setRequestHeader "Referer", Url_a
       .send PostJson
       
        Set Json = Jsondata.JsonParse(.responsetext)
   
        For i = 0 To CallByName(CallByName(Json, "d", VbGet), "length", VbGet) - 1
            Set temp = CallByName(CallByName(Json, "d", VbGet), i, VbGet)
            Cells(i + 1, 1) = temp.Date
            Cells(i + 1, 2) = temp.Price
        Next i
            
    End With
    
    
    Set Xmlhttp = Nothing
    Set Jsondata = Nothing
    Set Json = Nothing
    Set temp = Nothing
    
End Sub

tmwcykixe wrote:
原來如此，我本以為vba送出2次send是上2次網站的意思耶。...(恕刪)

tmwcykixe wrote:
如輸入amzn可得fID=6337、pw=209079，輸入aapl可得 fid=4614、pw =152220(恕刪)

tmwcykixe wrote:
但該網頁不知為何輸入幾次後就會跳出登錄畫面，這點不知樓主有解方嗎?(恕刪)