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

tang7325 wrote:
還有你怎麼能了解是第16個Table, 你有算一下, 是嗎?

機八陽 wrote:
"https://goodinfo.tw/StockInfo/StockList.asp?MARKET_CAT=自訂篩選&INDUSTRY_CAT=我的條件&FL_ITEM0=連續配發合計股利次數

'公開資訊觀測站(即時重大訊息，詳細資料)下載範例
'程式碼放在module1(模組)裡
Sub Get_twse_即時重大訊息()

    Dim HTML As Object, Getxml As Object, table As Object, i As Integer, j As Integer, url As String, Url_a As String, ttt As Double
    Dim Ie_Open As Boolean

'這裡有2種顯示方式(預設ie_open=true)
    Ie_Open = True '使用超連結，點擊插入註解，打開瀏覽器



    'Ie_Open = False '使用文字格式網址，點擊插入註解，但不打開瀏覽器

  


'下載的資料放在註解裡面



    
    Set HTML = CreateObject("htmlfile")
    Set Getxml = CreateObject("msxml2.xmlhttp")
  
    url = "https://mops.twse.com.tw/mops/web/t05sr01_1"
    Url_a = "https://mops.twse.com.tw/mops/web/ajax_t05sr01_1"
    
    ActiveSheet.Cells.Clear
    Application.ScreenUpdating = False
    
    ttt = Timer
    
    With Getxml
        
       .Open "GET", url, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Cache-Control", "no-cache"
       .setRequestHeader "Pragma", "no-cache"
       .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
       .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
       .send
       
        HTML.body.innerhtml = .responsetext
        
    End With
    
    Set table = HTML.getelementbyid("table01").getelementsbytagname("form")(1).getelementsbytagname("table")(0).Rows
    Dim PostData As String, skey As String, COMPANY_ID As String, SPOKE_DATE As String, SPOKE_TIME As String, SEQ_NO As String
    
    For i = 0 To table.Length - 1
        For j = 0 To table(i).Cells.Length - 1
            If j = 5 And i > 0 Then
            
                PostData = table(i).Cells(j).innerhtml
                skey = Split(Split(PostData, "skey.value='")(1), "'")(0)
                COMPANY_ID = Split(Split(PostData, "COMPANY_ID.value='")(1), "'")(0)
                SPOKE_DATE = Split(Split(PostData, "SPOKE_DATE.value='")(1), "'")(0)
                SPOKE_TIME = Split(Split(PostData, "SPOKE_TIME.value='")(1), "'")(0)
                SEQ_NO = Split(Split(PostData, "SEQ_NO.value='")(1), "'")(0)
                PostData = Url_a & "?encodeURIComponent=1&TYPEK=all&step=1&skey=" & skey & "&hhc_co_name=&firstin=true&COMPANY_ID=" & COMPANY_ID & "&COMPANY_NAME=&SPOKE_DATE=" & SPOKE_DATE & "&SPOKE_TIME=" & SPOKE_TIME & "&SEQ_NO=" & SEQ_NO
                
                If Ie_Open = True Then
                    ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(i + 1, j + 1), Address:=PostData, TextToDisplay:="詳細資料"
                Else
                    ActiveSheet.Cells(i + 1, j + 1) = PostData
                End If
            Else
                ActiveSheet.Cells(i + 1, j + 1) = Trim(table(i).Cells(j).innertext)
            End If
        Next j
    Next i
    
    'ActiveSheet.Columns.AutoFit
    Application.ScreenUpdating = True
    
    Set HTML = Nothing
    Set Getxml = Nothing
    Set table = Nothing
    
    Debug.Print Timer - ttt & "s(download link)"
    
End Sub


'===============================================
'以下程式碼放在“工作表1”
'===============================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    If InStr(CStr(Target.Address), ":") > 0 Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    
    If Intersect(Target, Columns("F:F")) Is Nothing Then
      ' out
    Else
        If Target.Offset(, -1).Comment Is Nothing Then
            ' no old comment
        Else
            If InStr(Target.Offset(, -1).Comment.Text, "查詢過於頻繁") = 0 Then
                'download ok
                Exit Sub
            Else
                Target.Offset(, -1).ClearComments
            End If
            
        End If
        
        If Target.Value = "詳細資料" Then
            Target.Offset(, -1).AddComment.Text Get_twse_詳細資料(Target.Hyperlinks.Item(1).Address)
        Else
            Target.Offset(, -1).AddComment.Text Get_twse_詳細資料(Target.Value)
        End If
        Target.Offset(, -1).Comment.Shape.TextFrame.AutoSize = True
        
    End If
    
End Sub


Function Get_twse_詳細資料(url As String) As String

'有另存文字檔需求的，請參考其它範例改寫此function

    Dim HTML As Object, Getxml As Object, ttt As Double
    Set HTML = CreateObject("htmlfile")
    Set Getxml = CreateObject("msxml2.xmlhttp")
    
    ttt = Timer
    
    With Getxml
        
        .Open "POST", url, False
        .setRequestHeader "Referer", "https://mops.twse.com.tw/mops/web/t05sr01_1"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send
        HTML.body.innerhtml = .responsetext
        
    End With
    
    Get_twse_詳細資料 = HTML.body.innertext
    
    Set HTML = Nothing
    Set Getxml = Nothing
    Set table = Nothing
    
    Debug.Print Timer - ttt & "s"
    
End Function

whu1101 wrote:
刪除(恕刪)