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

RyuuzakiYu wrote:
公開觀測站的當日重大訊息

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, y As String, m As String, d As String, Lastrow As Integer
    
    Set HTML = CreateObject("htmlfile")
    Set Getxml = CreateObject("msxml2.xmlhttp")
    
    url = "https://mops.twse.com.tw/mops/web/ajax_t05st02"
    Url_a = "https://mops.twse.com.tw/mops/web/t05st02"
    
    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Range("A:C").NumberFormatLocal = "@"
    Application.ScreenUpdating = False
    
    
    y = "112"
    m = "04"
    d = "25"
    
    ttt = Timer
    
    With Getxml
        
       .Open "POST", 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 ("encodeURIComponent=1&step=1&step00=0&firstin=1&off=1&TYPEK=all&year=" & y & "&month=" & m & "&day=" & d)
       
        HTML.body.innerhtml = .responsetext
        
    End With
    
    
    Set table = HTML.all.tags("table")(2).Rows
    For i = 0 To table.Length - 1
        For j = 0 To table(i).Cells.Length - 1
                Sheets("工作表1").Cells(i + 1, j + 1) = Trim(table(i).Cells(j).innertext)
        Next j
    Next i
    
    Lastrow = i
    Set table = HTML.all.tags("table")(3).Rows
    For i = 0 To table.Length - 1
        For j = 0 To table(i).Cells.Length - 1
                Sheets("工作表1").Cells(i + 1 + Lastrow, j + 1) = Trim(table(i).Cells(j).innertext)
        Next j
    Next i


    Sheets("工作表1").Columns.AutoFit
    Application.ScreenUpdating = True
    
    Set HTML = Nothing
    Set Getxml = Nothing
    Set table = Nothing
    
    
End Sub

goldchiou wrote:
在google找不到相關方法，自行試了幾種方法想要登入

' 登入網頁，取得自己的會員名稱    

Sub Get_histock()


    Dim Xmlhttp As Object, url As String, vs As String, ev As String, url_a As String, temp, test
    Dim Email As String, Password As String

    Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    '這裡請改成自己的帳號、密碼
    Email = "aaaa@aaa.aaa.aaa"
    Password = "0000"
    
    
    url = "https://histock.tw/login"
    
    With Xmlhttp
        
        .Open "GET", url, False
        .setRequestHeader "Connection", "Keep-Alive"
        .send
        
        vs = Split(Split(.responsetext, "__VIEWSTATE"" value=""")(1), """")(0)
        ev = Split(Split(.responsetext, "__EVENTVALIDATION"" value=""")(1), """")(0)
        vg = Split(Split(.responsetext, "__VIEWSTATEGENERATOR"" value=""")(1), """")(0)
        
    '密碼不確定能不能有符號，如果有，可能需要編碼，把Password 改成UrlEncode(Password)
        url_a = "__EVENTTARGET=&__EVENTARGUMENT=&__VIEWSTATE=" & UrlEncode(vs) & "&__VIEWSTATEGENERATOR=" & vg & "&__EVENTVALIDATION=" & UrlEncode(ev) & "&email=" & UrlEncode(Email) & "&password=" & Password & "&bLogin=%E7%99%BB%E5%85%A5"
    
        
        '登入
        .Open "POST", url, False
        .setRequestHeader "Referer", url
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Content-Length", Len(url_a)
        .setRequestHeader "Connection", "Keep-Alive"
        .send (url_a)
        
        
        '會員資訊
        .Open "GET", "https://histock.tw/my", False
        .setRequestHeader "Referer", "https://histock.tw/default.aspx"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Connection", "Keep-Alive"
        .send
        
        
        temp = Split(.responsetext, vbNewLine)
    
        For Each test In temp
            If InStr(test, "頭銜") > 0 Then
                MsgBox test, vbOKOnly, "登入測試"
                Exit For
            End If
        Next
        
    End With
        
    Set Xmlhttp = Nothing
    
    
End Sub

'下面是圖片，請手動輸入，或參考附件

tajenchung wrote:
把With Sheets("sheet1")改成With Sheets("temp")
即時運算視窗出現錯誤訊息:
Class Range 的 Select 方法失敗

…………
…………
…………
  With Sheets("temp")
          .Activate
…………
…………
…………

tajenchung wrote:

若我把程式改成以下:
Sheets("temp").Select
ActiveSheet.Cells(1, 1).PasteSpecial NoHTMLFormatting:=True
ActiveSheet.Range("b1").Cut Destination:=ActiveSheet.Range("a2")
ActiveSheet.Range("c1").Clear
ActiveSheet.Cells(2, 1).Select

即時運算視窗出現錯誤訊息:

應用程式或物件定義上的錯誤

…………
…………
…………

          Sheets("temp").Select
          ActiveSheet.Cells(1, 1).Select
          ActiveSheet.PasteSpecial NoHTMLFormatting:=True

…………
…………
…………

bank87012 wrote:
請問如何簡化程式碼與加速執行速度
Sub 外本比()

Dim oXML As Object

bank87012 wrote:
請問URL與URL_A有機會變成下拉式篩選需要的項目嗎?

Sub addlistbox()
    
    Dim list_0, List_1
    On Error Resume Next
    
    With Sheets("工作表1")
    
        .Select
        .Shapes.Range(Array("List_0", "List_1")).Delete
        .Cells.Clear
        
        Set list_0 = .ListBoxes.Add(.Range("a3").Left + 1, .Range("a3").Top, 82, 400)
        Set List_1 = .ListBoxes.Add(.Range("d3").Left + 1, .Range("d3").Top, 82, 400)
        
        With list_0
            .Name = "list_0"
            .List = Array("a", "b", "c", "d", "e", "f")   '參數
            .Selected(1) = True
            .OnAction = "Listbox_Change"
        End With
        
        With List_1
            .Name = "list_1"
            .List = Array("1", "2", "3", "4", "5")     '參數
            .Selected(5) = True
            .OnAction = "Listbox_Change"
        End With
        
    End With
    
End Sub
Sub Listbox_Change()

    Dim a As String, b As String
    a = Sheets("工作表1").ListBoxes("list_0").List(Sheets("工作表1").ListBoxes("list_0"))
    b = Sheets("工作表1").ListBoxes("list_1").List(Sheets("工作表1").ListBoxes("list_1"))
    
    Sheets("工作表1").Range("g3") = a & b

End Sub