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

clothk73713 wrote:
我想將 1234活頁簿內的工作表(1)範圍 H:Z 全部COPY給3333活頁簿內的所有工作表 裡面有 100個工作表 有比較方便的寫法嗎

snare wrote:
迴圈for i=1 to...(恕刪)

rainbowsperm wrote:
我要如何取得上圖紅框中要找的特定資料(恕刪)

'.........
.Open "POST", "https://mops.twse.com.tw/mops/web/ajax_t105sb02", False
.send ("encodeURIComponent=1&firstin=true&TYPEK=otc&step=0&co_id=6223")
'.........
Set Table =.........
debug.print  Table(3).Cells(16).innertext
debug.print  Table(3).Cells(17).innertext
'.........

snare wrote:
一、chrome(or(恕刪)

lpviva wrote:
Goodinfo好像改了第三層資訊真實網址的位置，所以無法擷取其資料，但使用原來方法Name欄位中已經找不到stocklist..., 還想請教如何取得其真實網址?謝謝

'因語法衝突，po文中的 [removed]，請手動修改成 innerHTML，前面再加個.(小數點)，或直接參考附件

Sub get_goodinfo()

    Dim Xmlhttp As Object, HTMLsourcecode As Object, Table, Url As String, Url_a As String, i As Integer, p As Integer, ttt As Double
    
    Set HTMLsourcecode = CreateObject("htmlfile")
    Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    Application.ScreenUpdating = False
    Sheets("工作表1").Cells.Clear
    ttt = Timer
    
    Url = "https://goodinfo.tw/tw2/StockList.asp?RPT_TIME=&MARKET_CAT=" & UrlEncode("熱門排行&INDUSTRY_CAT=融資減少張數 (一個月)@@融資增減張數@@減少張數 – 一個月&SHEET=資券增減統計_融資餘額&SHEET2=增減(張)")
    Url_a = "https://goodinfo.tw/tw2/StockList.asp?SEARCH_WORD=&SHEET=" & UrlEncode("資券增減統計_融資餘額&SHEET2=增減(張)&MARKET_CAT=熱門排行&INDUSTRY_CAT=融資減少張數 (一個月)@@融資增減張數@@減少張數 – 一個月&STOCK_CODE=&RPT_TIME=最新資料&STEP=DATA&RANK=")

'為了容易修改參數、程式美觀，網址另外用副程式編碼處理。
'這樣程式碼觀看起來比較直覺，網址也不會出現一大堆看不懂的亂碼。

'例如：
'如果要下載，熱門排行 – 成交價 (高→低) (共計2090筆)  
'只需要把網址修改如下，其它程式碼不需變動

'    Url = "https://goodinfo.tw/tw2/StockList.asp?RPT_TIME=&MARKET_CAT=" & UrlEncode("熱門排行&INDUSTRY_CAT=成交價 (高→低)@@成交價@@由高→低")
'    Url_a = "https://goodinfo.tw/tw2/StockList.asp?SEARCH_WORD=&SHEET=" & UrlEncode("交易狀況&SHEET2=日&MARKET_CAT=熱門排行&INDUSTRY_CAT=成交價 (高→低)@@成交價@@由高→低&STOCK_CODE=&RPT_TIME=最新資料&STEP=DATA&RANK=")











    With Xmlhttp
        
        i = 0
        
        Do
            DoEvents
            .Open "POST", Url_a & i, False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .setRequestHeader "Referer", Url
            .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
            .send
            
            HTMLsourcecode.body[removed] = convertraw(.ResponseBody)
            
            If InStr(HTMLsourcecode.body[removed], "瀏覽量異常") > 0 Then
                MsgBox HTMLsourcecode.body.innertext
                Exit Sub
            End If
            
            If i = 0 Then
                p = Replace(Right(HTMLsourcecode.getElementById("selRANK").innertext, 4), "~", "")
                MsgBox p & "筆(debug)，按確定後開始下載"  'debug
                p = WorksheetFunction.RoundUp(p / 300, 0)
                
            End If
            
            '==========================
            '剪貼薄方式(2選1)
            'Set Table = HTMLsourcecode.getElementById("divStockList") 'txtStockListData
            'Call Clipboard_Past("工作表1", Table)
            '==========================
        
            '==========================
            '逐格寫入方式(2選1)
            Set Table = HTMLsourcecode.getElementById("tblStockList").Rows
            Call Cell_by_Cell("工作表1", Table)
            '==========================

            i = i + 1
            If i > 10 Then Exit Do
            Delaytick (16)  '建議至少10秒以上，預設16秒
            
        Loop Until i = p
        
        Sheets("工作表1").Cells(1, 1).Select
        Sheets("工作表1").Cells.EntireColumn.AutoFit
           
 
    End With
    
    Application.ScreenUpdating = True
    
    Set HTMLsourcecode = Nothing
    Set Xmlhttp = Nothing
    Set Table = Nothing
    
    MsgBox Timer - ttt
    
End Sub

Sub Clipboard_Past(sheet_name As String, Table)
    
    Dim Clipboard As Object, lastrow As Integer
    Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
    Clipboard.settext Table[removed]
    Clipboard.putinclipboard
    
    lastrow = Sheets(sheet_name).Range("A1").CurrentRegion.Rows.Count
    Sheets(sheet_name).Cells(lastrow + IIf(lastrow > 1, 1, 0), 1).Select
    Sheets(sheet_name).PasteSpecial NoHTMLFormatting:=True
      
    Set Clipboard = Nothing
    
End Sub

Sub Cell_by_Cell(sheet_name As String, Table)
    
    Dim i As Integer, j As Integer, lastrow As Integer
    
    lastrow = Sheets(sheet_name).Range("A1").CurrentRegion.Rows.Count
    
    For i = 0 To Table.Length - 1
        For j = 0 To Table(i).Cells.Length - 1
            Sheets(sheet_name).Cells(i + 1 + IIf(lastrow > 1, lastrow, 0), j + 1) = IIf(j = 1, "'", "") & Table(i).Cells(j).innertext
        Next j
    Next i
   

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


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

'urlencode 副程式是圖片，請手動輸入，或參考附件