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

tmwcykixe wrote:
https://www.wantgoo.com/investrue/2330/retro-monthly-candlesticks?after=1633017600000

snare wrote:
wantgoo 網頁(恕刪)

tmwcykixe wrote:
好詭異,您試可以,我(恕刪)

.SetRequestHeader "Cookie", "BID=A4672B92-3858-402... 後面略
.SetRequestHeader "X-Client-Signature", "575236... 後面略

六、只要換股票代碼，key值，就需重新複製

htnvt241 wrote:
要怎麼抓 cmoney 的資料(如下列網址中最下面的 本益比的表格資料) ?
https://www.cmoney.tw/finance/f00032.aspx?s=2377

'請配合751樓範例修改

'…中間略…

 Url = "https://www.cmoney.tw/finance/f00032.aspx?s=" & stock

'…中間略…

 cmkey = Split(Split(.responsetext, "title='本益比' cmkey='")(1), "'>本益比<")(0)
Url_a = "https://www.cmoney.tw/finance/ashx/mainpage.ashx?action=GetPERAndEPSBySeason&stockId=" & stock & "&cmkey=" & cmkey

'…中間略…

  Range("a1:g1") = Array("年季", "收盤價", "法人預估本益比", "本益比(近4季)", "本益比(季高)", "本益比(季低)", "EPS")
        
        For i = 0 To CallByName(Json, "length", VbGet) - 1
            
            Cells(i + 2, 1) = WorksheetFunction.Replace(CallByName(CallByName(Json, i, VbGet), "SeasonDate", VbGet), 5, 1, "Q")
            Cells(i + 2, 2) = CallByName(CallByName(Json, i, VbGet), "ClosePr", VbGet)
            '其它5筆資料請自行練習用callbyname取出
            
        Next i




'…中間略…

snare wrote:
放棄，key值一定要(恕刪)

'股票代碼放在a欄

Sub test()
    
    Dim i As Integer, lastrow As Integer, URL As String, sheetName As String, ttt As Double
    Application.ScreenUpdating = False
    
    ttt = Timer
    sheetName = "工作表1"
    
    With Sheets(sheetName)
        .Range("B:U").Clear:        .Range("b1:c1") = Array("股票名稱", "股票價格")
        lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
        If lastrow = 1 Then Exit Sub
        For i = 2 To lastrow
            URL = "https://pchome.megatime.com.tw/stock/sid" & .Cells(i, 1) & ".html"
            Call Get_Pchome_stock_線型走勢(sheetName, URL, i)
        Next i
        
        '=================================
        '排版，請自行調整
        .Cells.Font.Size = 10
        .Range("a1:u1").Font.Size = 8
        .Range("a1:u1").Font.Bold = True
        .Columns.ColumnWidth = 10
        .Columns("B:D").EntireColumn.AutoFit
        '=================================
        
    End With
    Application.ScreenUpdating = True
    
    Debug.Print Timer - ttt
    
End Sub

Sub Get_Pchome_stock_線型走勢(sheetName As String, URL As String, r As Integer)

      
    Dim HTML As Object, Getxml As Object, table As Object, i As Integer, j As Integer, c As Integer
    Set HTML = CreateObject("htmlfile")
    Set Getxml = CreateObject("msxml2.xmlhttp")
    On Error Resume Next
    
    With Getxml
        
       .Open "POST", URL, False
       .setRequestHeader "Referer", "https://stock.pchome.com.tw/"
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Content-Length", LenB("is_check=1")
       .send ("is_check=1")
        
        HTML.body.innerhtml = .responsetext
        
        If InStr(.responsetext, "查無此股票") > 0 Then
            Sheets(sheetName).Cells(r, 2) = "查無此股票"
            Sheets(sheetName).Cells(r, 2).Font.Color = vbRed
            Exit Sub
        Else
         
'因語法問題，這行改用圖片，請手動輸入，或參考附件



        End If

    End With
    
    Sheets(sheetName).Cells(r, 3) = HTML.getElementById("stock_info_data_a").innertext
    
    'only price
    'Sheets(sheetName).Cells(r, 3) = Split(HTML.getElementById("stock_info_data_a").innertext, " ")(0)
    
    Set table = HTML.All.tags("table")(1).Rows
 
    For i = IIf(r = 2, 2, 3) To 7 Step IIf(r > 2, 2, 1)
            c = ((i - 2) \ 2) * 6 + 4
            For j = 0 To table(i).Cells.Length - 1
                Sheets(sheetName).Cells(IIf(r = 2, (i Mod 2) + 1, r), c) = table(i).Cells(j).innertext
                c = c + 1
            Next j
    Next i
    
    Set HTML = Nothing
    Set Getxml = Nothing
    Set table = Nothing
    
    
End Sub

activer wrote:
由於合庫銀行歷史匯率已改版為JSON,小弟試著套用範例部分程式碼,自訂區間方式,仍無法抓到資料 (恕刪)

Sub Get_tcb_bank_Json()

      
    Dim Jsondata As Object, DecodeJson, Getxml As Object, URL As String, R_V_Token As String, URL_a As String
    Dim StartDate As String, EndDate As String, CurrencyCode As String
    
    Set Getxml = CreateObject("msxml2.xmlhttp")
    Set Jsondata = CreateObject("HtmlFile")


    
    'test
    CurrencyCode = "USD"
    'CurrencyCode = "JPY"
    StartDate = "2022-01-01"
    EndDate = "2022-01-22"
    
    URL = "https://www.tcb-bank.com.tw/personal-banking/deposit-exchange/exchange-rate/historical-rate"
    URL_a = "https://www.tcb-bank.com.tw/api/client/ForeignExchange/GetHistoryForeignExchange"
    
    With Getxml
        
       .Open "GET", URL, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:96.0) Gecko/20100101 Firefox/96.0"
       .send
        
        
       R_V_Token = Split(Split(.responsetext, """__RequestVerificationToken"" type=""hidden"" value=""")(1), """ />")(0)
       
        
       .Open "POST", URL_a, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:96.0) Gecko/20100101 Firefox/96.0"
       .send ("__RequestVerificationToken=" & R_V_Token & "¤cy=" & CurrencyCode & _
              "&dateoptions=custom&startdate=" & StartDate & "&enddate=" & EndDate)
        
       Set DecodeJson = CallByName(Jsondata.JsonParse(.responsetext), "result", VbGet)

    End With

'json整理，請參考其它範例    

    Set Getxml = Nothing
    Set Jsondata = Nothing
    
    
    
End Sub