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

lpviva wrote:
但不知如何刪除下拉選單框。
(恕刪)

lpviva wrote:
修改程式URL位置指向goodinfo融資餘額處，執行程式後結果畫面，無資料載入。
(恕刪)

lpviva wrote:
goodinfo融資餘額下載畫面，下載時選單中的"排名範圍選擇"希望由原來的指定300檔，自動修改為"全部顯示"
(恕刪)

'(多次下載，請自行練習改寫)

Sub get_goodinfo()

    Dim HTMLsourcecode, table, Clipboard As Object, Url As String, URL_a As String
    Set HTMLsourcecode = CreateObject("htmlfile")
    Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

    Url = "https://goodinfo.tw/StockInfo/StockList.asp?SEARCH_WORD=&SHEET=融資融券&SHEET2=資券增減統計&MARKET_CAT=熱門排行&INDUSTRY_CAT=融資餘額&STOCK_CODE=&RPT_TIME=最新資料&STEP=DATA&RANK="

'RANK=0   1~300
'RANK=1   301~600
'RANK=2   601~900
'RANK=3   901~1200
'RANK=4   1201~1500
'RANK=5    1501~1575

    URL_a = "https://goodinfo.tw/StockInfo/StockList.asp?MARKET_CAT=熱門排行&INDUSTRY_CAT=融資餘額&SHEET=融資融券&SHEET2=資券增減統計&RPT_TIME="

    With CreateObject("WinHttp.WinHttpRequest.5.1")
'for i=0 to 5 ......迴圈開始位置
        .Open "POST", Url & "0", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", URL_a
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send

        HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)
        Set table = HTMLsourcecode.getElementById("divStockList") ' 剪貼薄方式
        'Set table = HTMLsourcecode.all.tags("table")(1).Rows '逐格寫入方式

       '整理用程式碼，請參考其它範例自行補上

'next i ...….迴圈結束位置
    End With


    Set HTMLsourcecode = Nothing
    Set table = Nothing
    Set Clipboard = Nothing
    
    
End Sub
Function convertraw(rawdata)

    Dim rawstr
    Set rawstr = CreateObject("adodb.stream")

    With rawstr
        .Type = 1
        .Mode = 3
        .Open
        .Write rawdata
        .Position = 0
        .Type = 2
        .Charset = "utf-8"
        convertraw = .ReadText
        .Close
    End With

    Set rawstr = Nothing

End Function

'ie object goodinfo+facebook登入 慢速版
Sub Test()
        
    Dim IE As Object, DOM_event As Object, Url As String, table, i As Integer, j As Integer
    
    ActiveSheet.Cells.Clear
    Application.ScreenUpdating = False
    On Error Resume Next
    
    Set IE = CreateObject("InternetExplorer.Application")
    
    With IE
        .Visible = True
        .Navigate "https://goodinfo.tw/StockInfo/index.asp"
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
        
        .document.all.Item("linkLoginFacebook").Click
        Application.Wait (Now + TimeValue("0:00:10")) '等待facebook登入畫面，視電腦效能、網路狀態，修改適合時間
            
        .document.all.Item("email").Value = "facebook 使用者名稱"
        .document.all.Item("pass").Value = "facebook 使用者密碼"
        .document.all.Item("loginbutton").Click
         Application.Wait (Now + TimeValue("0:00:10")) '等待網頁跳轉，視電腦效能、網路狀態，修改適合時間
         
 
        Url = "https://goodinfo.tw/StockInfo/StockList.asp?MARKET_CAT=%E7%86%B1%E9%96%80%E6%8E%92%E8%A1%8C&INDUSTRY_CAT=%E8%9E%8D%E8%B3%87%E9%A4%98%E9%A1%8D&SHEET=%E8%9E%8D%E8%B3%87%E8%9E%8D%E5%88%B8&SHEET2=%E8%B3%87%E5%88%B8%E5%A2%9E%E6%B8%9B%E7%B5%B1%E8%A8%88&RPT_TIME="
       '"https://goodinfo.tw/StockInfo/StockList.asp?MARKET_CAT=熱門排行&INDUSTRY_CAT=融資餘額&SHEET=融資融券&SHEET2=資券增減統計&RPT_TIME="
      
         .Navigate Url
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
        
        Set DOM_event = .document.createEvent("HTMLEvents")
        DOM_event.initEvent "change", True, False
        
        .document.all.Item("selRANK").selectedindex = 6
        .document.all.Item("selRANK").dispatchEvent DOM_event
        
        Application.Wait (Now + TimeValue("0:00:40")) '等待查詢結果，視電腦效能、網路狀態，修改適合時間
        
        Set table = .document.getelementsbytagname("table")(96).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
        
        ActiveSheet.Cells.Columns.AutoFit

    End With
    
    IE.Quit
    Set IE = Nothing
    Set table = Nothing
        
    Application.ScreenUpdating = True
        
End Sub

rainbowsperm wrote:
我Sub getpost常會卡在
Set HTMLsourcecode = CreateObject("htmlfile")
只要一卡住就不能work
有時重開機就可以跑過, 有時就會卡住...(恕刪)

Sub test()

     Dim htmlsourcecode As Object
     
     For i = 1 To 1000
        Set htmlsourcecode = CreateObject("htmlfile")
        Cells(1, 1) = i
        Set htmlsourcecode = Nothing
     Next i

End Sub

snare wrote:
set 只是指派物件(恕刪)

snare wrote:
網址不對，xmlhttp...(恕刪)

lpviva wrote:
1. 有關於Rank的變數設定每300筆資料下載一次, snare已將其標註，我沒改，不知Rank實際上是否是URL變數中引數的一部分?
(恕刪)

lpviva wrote:
2.迴圈這樣設定是否正確?
(恕刪)

lpviva wrote:
經過一陣子電腦的計算在沒有在EXCEL工作表中出現與snare兄示範一樣的有資料結果，而是空白一片
(恕刪)

snare wrote:
vba 中顯示“綠色(恕刪)

rainbowsperm wrote:
請問以下這類的網站 要用什麼方式擷取資料 會比較快呢? 該參考哪一樓層的說明
謝謝
http://financials.morningstar.com/income-statement/is.html?t=AAPL&region=usa&culture=zh-TW&platform=sal (恕刪)

snare wrote:
寫法同223樓，csv(恕刪)