iInfo 資訊交流: Excel VBA抓取上櫃交易明細

2012年10月9日星期二

Excel VBA抓取上櫃交易明細

使用QueryTables與XMLHTTP方法快速抓取上櫃股票各分點劵商的交易明細。

上櫃個股買賣日報表

抓取交易明細完成畫面

VBA程式碼如下

Option Explicit

Dim TempSheet, oXMLHTTP, objStream, StartTime
Dim i As Integer, n As Integer, l As Integer, j As Integer
Dim qyt As QueryTable
Dim saledate As String, FilePath As String, FileName As String, webdate As String

Private Sub CommandButton1_Click()
    下載全部資料
End Sub

Sub 下載全部資料()
    StartTime = Now
    
    saledate = Year(Date) & Format(Month(Date), "00") & Format(Day(Date), "00")
    saledate = "20121012" '指定專屬日期
    
    Application.ScreenUpdating = False
    
    '建立暫存工作表
    If 確認工作表存在("Temp") <> True Then
        Application.StatusBar = "建立暫存工作表"
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"    '建立指定工作到現存工作表的對後面
        Set TempSheet = Sheets("Temp")
    Else
        Application.StatusBar = "清除暫存工作表"
        Set TempSheet = Sheets("Temp")
        清除暫存工作表
    End If
    
    Application.StatusBar = "抓股票代碼"
    抓股票代碼
    
    Application.StatusBar = "刪除空白資料列"
    刪空特定列
    
    Application.StatusBar = "解析股票代碼"
    解析股票代碼
    
    '交易明細路徑可自行修改
    FilePath = "D:\OTC\"
    If Dir(FilePath, vbDirectory) = "" Then
        MkDir (FilePath)
    End If
    
    '交易明細路徑可自行修改
    FilePath = "D:\OTC\" + saledate + "\"
    Application.StatusBar = "建立" + FilePath + "資料夾"
    If Dir(FilePath, vbDirectory) = "" Then
        MkDir (FilePath)
    End If
        
    n = Sheet1.Cells(65536, 1).End(xlUp).Row
    For i = 2 To n
        下載交易明細 FilePath, Cells(i, 1), saledate
        Application.StatusBar = "正在抓取 " + CStr(Cells(i, 1)) + " " + CStr(Cells(i, 2)) + " 交易明細... 已完成" + Format(i / n * 100, ".00") + "%"
    Next
    Application.StatusBar = "上櫃交易明細抓取結束"

    Application.ScreenUpdating = True
    
    MsgBox saledate & "上櫃交易明細下載 共花費 " & Format(Now - StartTime, "HH時mm分ss秒") & " 下載完成。" & vbCrLf & "以秒計算 共花費 " & DateDiff("s", StartTime, Now) & " 秒下載完成", vbInformation
    
    Set TempSheet = Nothing
End Sub

Sub 下載交易明細(FilePath As String, stockid As String, saledate As String)
    Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")
    Set objStream = CreateObject("ADODB.stream")
   
    webdate = Replace(saledate, Year(Date), CStr(CInt(Year(Date)) - 1911))
    FileName = FilePath + "\" + saledate + "_" + stockid + ".CSV"
    
    With oXMLHTTP
        .Open "POST", "http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/download_ALLCSV.php", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send "curstk=" & stockid & "&stk_date=" & webdate
        
        If .readyState = 4 Then '.Status = 200
            With objStream
                .Type = 1       '以二進位方式操作
                .Open           '開啟物件
                .Write oXMLHTTP.ResponseBody
                
                If Dir(FileName) <> "" Then Kill FileName
                .SaveToFile FileName
                .Close
            End With
        End If
    End With
    
    Set oXMLHTTP = Nothing
    Set objStream = Nothing
End Sub

Sub 解析股票代碼()
    With TempSheet
        With Sheet1
            .Cells(1, 1) = "股票代碼"
            .Cells(1, 2) = "公司名稱"
            n = 2
            For i = 2 To .Cells(65536, 6).End(xlUp).Row
                If Trim(TempSheet.Cells(i, 6)) = "ESVUFR" Or _
                   Trim(TempSheet.Cells(i, 6)) = "EUOMSR" Or _
                   Trim(TempSheet.Cells(i, 6)) = "EMXXXA" Or _
                   Trim(TempSheet.Cells(i, 6)) = "ESVUFA" Then
                   
                    .Cells(n, 1) = Split(.Cells(i, 1), "  ")(0)
                    .Cells(n, 2) = Split(.Cells(i, 1), "  ")(1)
                    n = n + 1
                End If
            Next i
        End With
    End With
End Sub

Sub 抓股票代碼()
    With TempSheet.QueryTables.Add("URL;http://isin.twse.com.tw/isin/C_public.jsp?strMode=4", TempSheet.Cells(1, 1))
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .Refresh 0
        If Err.Number <> 0 Then Err.Clear: MsgBox "資料查詢失敗"    '被免資料抓取不成功,而顯示訊息
        .Delete
    End With
End Sub

Sub 清除暫存工作表()
    With TempSheet                              '選取指定名稱工作表
        n = .Cells(65536, 6).End(xlUp).Row      '選取目前活頁簿從A1位置到最後一行的範圍
        l = .Cells(1, 1).End(xlToRight).Column
    
        If n = 1 Or l = 256 Then
            Exit Sub
        End If
        
        For Each qyt In TempSheet.QueryTables   '選取用QueryTables抓取的每一行
            qyt.Delete                          '將使用QueryTables方法所產生的行進行刪除,避免QueryTables用久了,造成系統堆積一堆QueryTables的垃圾,如此系統才部會變慢
        Next
    
        .Cells.Clear                            '清除所選取儲存格格式
        .Cells.ClearContents                    '清除所選取的資料
    End With
End Sub

Sub 刪空特定列()
    j = 0
    For i = 2 To TempSheet.Cells(65536, 6).End(xlUp).Row
        If TempSheet.Cells(i, 6).Value = Empty Then
            j = j + 1
            TempSheet.Rows(i & ":" & i).Delete Shift:=xlUp
            If n - j >= i Then
                i = i - 1
            End If
         End If
    Next
End Sub

Function 確認工作表存在(strWSName As String) As Boolean
    Dim Temp As Excel.Worksheet
    On Error Resume Next
    
    Set Temp = Worksheets(strWSName)
    If Not Temp Is Nothing Then
        確認工作表存在 = True
        On Error GoTo 0
        Set Temp = Nothing
        Exit Function
    End If
    
    確認工作表存在 = False
    On Error GoTo 0
    Set Temp = Nothing
End Function

若是不想寫code，考參考這裡下載。

[2014/01/03]櫃買中心改版，程式碼修改部分
近期櫃買中心改版，影響交易明細下載，目前驗證出來的結果有以下幾點須注意：

網站會紀錄IP，可採行使用3G網卡，斷線再連線重試。
不能快速存取交易明細，須加延遲時間2~5秒。
在5秒內左右快速存取三次檔案，在第四筆檔案以後將會無法存取。
如上若第四次無法存取後，又一直以快速存取，網站伺服器將紀錄IP拒絕存取，連帶網頁也無法開啟，需等待20分鐘以上甚至更久，可參考第一點注意事項的解法。
參數傳送方式變更。

2014/01/03櫃買中心網站修改修改版，請考參考這裡下載。

以上櫃買中心網站變更項目僅是個人推估，如有錯誤請提供糾正，變更程式碼參考如下：

Sub 下載交易明細(FilePath As String, stockid As String, saledate As String)
    Dim url As String
    
    Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")
    Set objStream = CreateObject("ADODB.stream")
   
    webdate = Replace(saledate, Year(Date), CStr(CInt(Year(Date)) - 1911))
    FileName = FilePath + "\" + saledate + "_" + stockid + ".CSV"
    
    Delay 3 '加入延遲
    
    url = "http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & stockid & "&stk_date=" & webdate
    With oXMLHTTP
        .Open "POST", url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        '.setRequestHeader "Referer", "http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/brokerBS.php"
        '.setRequestHeader "Host", "www.gretai.org.tw"
        .send
        
        Delay 1 '加入延遲
        
        If .readyState = 4 Then '.Status = 200
            With objStream
                .Type = 1       '以二進位方式操作
                .Open           '開啟物件
                .Write oXMLHTTP.ResponseBody
                
                If Dir(FileName) <> "" Then Kill FileName
                .SaveToFile FileName
                .Close
            End With
        End If
    End With
    
    Set oXMLHTTP = Nothing
    Set objStream = Nothing
End Sub

新增函數

Public Sub Delay(DelayTime As Single)
     Dim BeginTime As Single
     BeginTime = Timer
     While Timer < BeginTime + DelayTime
         DoEvents
     Wend
End Sub

[2014/07/11]櫃買中心改版，程式碼修改部分
近期櫃買中心改版，影響交易明細下載，目前驗證出來的結果有以下幾點須注意：

變更上櫃交易中心檔案下載網址。

Sub 下載交易明細(FilePath As String, stockid As String, saledate As String)
    Dim url As String
    
    Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")
    Set objStream = CreateObject("ADODB.stream")
   
    webdate = Replace(saledate, Year(Date), CStr(CInt(Year(Date)) - 1911))
    Filename = FilePath + "\" + saledate + "_" + stockid + ".CSV"
    
    Delay 3 '加入延遲
    
    url = "http://www.gretai.org.tw//web/stock/aftertrading/broker_trading/download_ALLCSV.php?curstk=" & stockid & "&stk_date=" & webdate
    With oXMLHTTP
        .Open "POST", url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        '.setRequestHeader "Referer", "http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/brokerBS.php"
        '.setRequestHeader "Host", "www.gretai.org.tw"
        .send
        
        Delay 1 '加入延遲
        
        If .readyState = 4 Then '.Status = 200
            With objStream
                .Type = 1       '以二進位方式操作
                .Open           '開啟物件
                .Write oXMLHTTP.ResponseBody
                
                If Dir(Filename) <> "" Then Kill Filename
                .SaveToFile Filename
                .Close
            End With
        End If
    End With
    
    Set oXMLHTTP = Nothing
    Set objStream = Nothing
End Sub

執行結果

2 則留言:

Josh2014年1月2日下午2:46
大大，是否櫃買資料源已經更改了呢? 目前都無法下載!
回覆刪除
回覆

新增留言

訂閱：張貼留言 (Atom)

iInfo 資訊交流

最新消息

2012年10月9日星期二

Excel VBA抓取上櫃交易明細

2 則留言:

LinkWithin

最新消息

2012年10月9日 星期二

Excel VBA抓取上櫃交易明細

2 則留言:

LinkWithin

2012年10月9日星期二