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

rainbowsperm wrote:
因為網路的問題, 程式常常會卡在.send的地方
試著用https://stackoverflow.com/questions/11407010/how-to-vba-callback-function-when-xmlhttp-ontimeout
的方法, 但好像沒用??

rainbowsperm wrote:
有辦法讓VBA偵測到timeout然後隔幾秒重試個幾次, 超過次數在exit嗎??

rainbowsperm wrote:
另外有個問題想請問, 我VBA會讀取清單去開啟檔案做更新(約10幾個table), 然後儲存關閉, 直到清單的檔案都開啟更新完畢為止
之前使用webrequst的方式, 他會一直跑至少跑幾百個才會停住, 現在改用XMLHTTP的方式都是跑10-30次就停止了, 請問您知道可能是什麼問題嗎?
謝謝

Sub test()

'假設a1~a30是股票代號
    For i = 1 To 30
        Delaytick (0.5)
'延遲0.5秒，建議可改亂數          
        If i > 15 Then
'超過15次，改排程下載
            Application.OnTime Now + TimeSerial(0, 0, 10), "'Get_xml " & """" & Cells(i, 1) & """" & "," & i & "'"
'排程10秒後再執行下載，建議可改亂數          
'Get_xml 後面必需加上一個空格，字串需加上"，數字不用，前後需加上'

        Else
            Call Get_xml(Cells(i, 1), i)
        End If
    Next i
     
    
End Sub


Sub Get_xml(stock_id As String, lastrow As Integer)
       
   re = 0
retry:
   On Error GoTo Error_debug
    
   '======================
   
   
   '下載用程式碼放這裡
   
   
   '======================
    
   Exit Sub
    
Error_debug:
    re = re + 1
    
    Delaytick (1.3)
    If re > 3 Then
'大於3次結束程式
       Debug.Print "error"
       re = 0
       Exit Sub
    End If
    
    If Err.Number <> 0 Then
'列出錯誤訊息，或利用不同的錯誤訊息，決定程式的處理方式
       Debug.Print "Get_xml：" & Err.Description
    End If
    
    On Error GoTo -1
    Err.Clear
    
    GoTo retry
    
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

snare wrote:
比起檢查timeout(恕刪)

rainbowsperm wrote:
請問如何偵測回傳有沒有資料, 可以這樣寫嗎?
(恕刪)
if HTMLsourcecode.body.innerhtml = "" then
(恕刪)

rainbowsperm wrote:
不過看到一大堆的錯誤好像都是
Get_xml：沒有設定物件變數或 With 區塊變數
(恕刪)

rainbowsperm wrote:
感覺這些錯誤沒關係??因為都可正確跑完, 只是跑久了就會卡住
關閉Excel再重開就可以再跑
(恕刪)

Sub 下載財報(stock_id As String)

    Application.ScreenUpdating = False

    Call 下載年報(stock_id)
    Call 下載季報(stock_id)
    Call 下載損益年表(stock_id)
    Call 下載損益季表(stock_id)
    Call 下載資產負債年表(stock_id)
    Call 下載資產負債季表(stock_id)
    ...
    ...
    ...
    call ......
    call ......
    
    Application.ScreenUpdating = true
    
End Sub

herricane5718 wrote:
目前在抓取"庫藏股清單"時, 碰到大部分資料無法抓到(用Debug.Print .responseText,即可發現),不知問題是出在哪裡?
' -----執行到這裡,查看 .responsetext, 發覺大部分的原始資料,都沒有下載到,
' -----不知上面的程式碼,哪裡有錯 ?

' -----在上面問題,沒有解決前,以下的程式碼,只是先寫著,暫且沒有意義
' -----目前可以判斷的出來,資料的table不止一個(有15個,需再判斷何者有用),
' -----將來需增加迴圈來處理,改寫程式碼

Sub get_twse()
    
    Dim Url As String, Url_a As String, Url_b As String, HTMLsourcecode As Object, GetXml As Object, i As Integer, j As Integer, k As Integer, lastrow As Integer
    Set HTMLsourcecode = CreateObject("htmlfile")
    Set GetXml = CreateObject("msxml2.xmlhttp")
    
    Url = "https://mops.twse.com.tw/mops/web/ajax_t35sc09"
    Url_a = "https://mops.twse.com.tw/mops/web/t35sc09"
    Url_b = "encodeURIComponent=1&step=1&firstin=1&off=1&TYPEK=sii&d1=1090204&d2=1090429&RD=1"
    
    Sheets("工作表1").Cells.Clear
    
    With GetXml
        .Open "POST", Url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", Url_a
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send (Url_b)
        

        HTMLsourcecode.body.innerhtml = .responsetext
        lastrow = 0
        
        For k = 0 To HTMLsourcecode.all.tags("table").Length - 1
        
            Set Table = HTMLsourcecode.all.tags("table")(k).Rows
            For i = 0 To Table.Length - 1
                lastrow = lastrow + 1
                For j = 0 To Table(i).Cells.Length - 1
                    ActiveSheet.Cells(lastrow, j + 1) = Table(i).Cells(j).innertext
                Next j
            Next i
        
        Next k
        
    End With
    
    Sheets("工作表1").Columns.AutoFit
    
    Set HTMLsourcecode = Nothing
    Set GetXml = Nothing
    Set Table = Nothing
    
End Sub