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

rainbowsperm wrote:
不過當貼到excel黨裡卻變成亂碼了

snare wrote:
我試沒問題(200樓(恕刪)

rainbowsperm wrote:
但該檔案好像是UTF-8

Sub test()

    Dim ADODBStream As Object, utf8_file As String
    
    Set ADODBStream = CreateObject("ADODB.Stream")

    Sheets("工作表1").Cells.Clear
    Application.ScreenUpdating = False

    With ADODBStream
        .Charset = "utf-8"
        .Open
        .LoadFromFile ("C:\excel\t86.csv") '完整路徑+檔名
        utf8_file = .ReadText()
        .Close
    End With

    Application.ScreenUpdating = True

    MsgBox utf8_file 'debug
   
    Set Clipboard = Nothing
    Set ADODBStream = Nothing

End Sub

snare wrote:
一、錄製巨集二、開啟(恕刪)

clothk73713 wrote:
請問大大 超級新手要學會VBA爬蟲有沒有 教學書籍推薦 完全沒底子但非常想學

'修正前執行


'修正後執行(需重開excel或重開機)





Sub tls_check()

    Dim Getxml As Object
    Set Getxml = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    On Error Resume Next
    
    With Getxml
        'check 1
        
        .Open "GET", "https://howsmyssl.com/a/check", False
        .send
        MsgBox Split(Split(.responsetext, "tls_version"":")(1), ",")(0)
        
        'check 2
        .Open "GET", "https://tlscheck.wubook.net", False
        .send
        MsgBox .responsetext
        
    End With
    
    Set Getxml = Nothing

End Sub

Sub Get_Pchome_stock()

'需先使用微軟tls修補程式
    'https://support.microsoft.com/zh-tw/help/3140245/update-to-enable-tls-1-1-and-tls-1-2-as-default-secure-protocols-in-wi

'如果要下載https://pchome.megatime.com.tw/ 裡面的其它連結
'只需改url網址，.tags("table")位置，其它程式碼不變，有需要請自行練習

    Dim HTMLsourcecode As Object, Getxml As Object, table As Object, i As Integer, j As Integer, Url As String, Url_a As String, ttt As Double
    Set HTMLsourcecode = CreateObject("htmlfile")
    Set Getxml = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    
    Url = "https://pchome.megatime.com.tw/rank/sto0/ock03.html" 'first page
    'Url = "https://pchome.megatime.com.tw/rank/sto0/ock03_2.html"
    'Url = "https://pchome.megatime.com.tw/rank/sto0/ock03_3.html"
    'Url = "https://pchome.megatime.com.tw/rank/sto0/ock03_4.html"
    'Url = "https://pchome.megatime.com.tw/rank/sto0/ock03_5.html" 'last page
    
    ActiveSheet.Cells.Clear
    Application.ScreenUpdating = False
    
    ttt = Timer
    
    With Getxml
        
        .Open "GET", Url, False
        .option(6) = False
        .send
        
        Url_a = .getResponseHeader("Location")

       .Open "POST", Url, False
       .setRequestHeader "Referer", Url_a
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Content-Length", LenB("is_check=1")
      '.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 ("is_check=1")
       
        HTMLsourcecode.body.innerhtml = .responsetext
        
    End With

    Set table = HTMLsourcecode.All.tags("table")(0).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.Columns.AutoFit
    Application.ScreenUpdating = True
    
    Set HTMLsourcecode = Nothing
    Set Getxml = Nothing
    Set table = Nothing
    
    Debug.Print "xml:" & Timer - ttt
    
End Sub

g80860 wrote:
是滙入網面,占太多記憶體,滙入資料很慢,幾乎快30分鐘,我快昏了.
請問:如何修改程式加快滙入,謝謝你.(恕刪)