最新消息

[公告2014/05/30] 如有需要將部落格中,任何一篇文章的程式碼使用在商業用途,請與我聯繫。

[公告2015/04/26] Line版的 iInfo程式與投資應用 群組已上線想加入的朋友們,請先查看 "入群須知" 再與我聯繫 Line : aminwhite5168,加入請告知身分與回答 "入群須知" 的問題。

[公告2018/04/22] 台北 Python + Excel VBA 金融資訊爬蟲課程,課程如網頁內容 金融資訊爬蟲班:台北班 Python 金融資訊爬蟲、EXCEL VBA 金融資訊爬蟲

[公告2019/01/08] 請注意:我再次重申,部落格文章的程式碼,是要提供各位參考與學習,一旦網頁改版請自行修改,別要求東要求西要我主動修改,你們用我寫東西賺錢了、交差了,請問有分我一杯羹嗎?既然賺錢沒分我,請問有什麼理由要求我修改,如果沒能力改,就花錢來找我上課。

[公告2019/12/01] 若各位有 Excel VBA 案子開發需求,歡迎與我聯繫,可接案處理。

[公告2020/05/22] 頁面載入速度慢,起因為部分JS來源(alexgorbatchev.com)失效導致頁面載入變慢,目前已做調整,請多見諒。

2012年10月17日 星期三

Excel VBA抓取上市交易明細

使用InternetExplorer.Application物件與QueryTables的方法來抓取,上市股票的劵商分點交易資料,可參考如下的程式碼




抓取上市股票代碼如下
Sub 找尋股票代碼()
    Dim i As Integer, n As Integer
    Dim stockurl As String
    Dim RowStart As Range, RowEnd As Range
    
    stockurl = "http://isin.twse.com.tw/isin/C_public.jsp?strMode=2"

    n = 2
    If SheetExists("Temp") <> True Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"    '建立指定工作到現存工作表的對後面
    Else
        清除工作表 "Temp"
    End If
    
    股票代碼 stockurl
    With Sheet1
        With Sheets("Temp")
            Sheet1.Cells(1, 1) = "股票代碼"
            Sheet1.Cells(1, 2) = "公司名稱"

            n = 2
            For i = 2 To .Cells(65535, 1).End(xlUp).Row
                If Trim(.Cells(i, 6)) = "ESVUFR" Or _
                   Trim(.Cells(i, 6)) = "EUOMSR" Or _
                   Trim(.Cells(i, 6)) = "EMXXXA" Or _
                   Trim(.Cells(i, 6)) = "ESVUFA" Then
                   
                    Sheet1.Cells(n, 1) = Split(.Cells(i, 1), "  ")(0)
                    Sheet1.Cells(n, 2) = Split(.Cells(i, 1), "  ")(1)
                    n = n + 1
                End If
            Next i
        End With
    End With
End Sub

Sub 儲存股票代碼(SaveDate As String)
    Dim TestObj As Object
    Dim CSVfile As String, CSVfolder As String
    Dim TestFolder As Boolean
    
    Set TestObj = CreateObject("Scripting.FileSystemObject")
    
    CSVfolder = FilePath & SaveDate & "\"
    CSVfile = CSVfolder & SaveDate & ".csv"
    
    TestFolder = TestObj.FolderExists(CSVfolder)
    If TestFolder = False Then TestObj.CreateFolder (CSVfolder)
    
    On Error Resume Next
    Kill CSVfile
    On Error GoTo 0
    
    Sheet1.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=CSVfile, FileFormat:=xlCSV
    Application.DisplayAlerts = True
    ActiveWorkbook.Close 0    
End Sub

Sub 股票代碼(StockIDURL As String)
    Dim xlSheet As Excel.Worksheet
    Set xlSheet = Sheets("Temp")
    With xlSheet.QueryTables.Add("URL;" & StockIDURL, xlSheet.Cells(1, 1))
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .Refresh 0
        .Delete
        If Err.Number <> 0 Then Err.Clear: MsgBox "資料查詢失敗"    '被免資料抓取不成功,而顯示訊息
    End With
    Set xlSheet = Nothing
End Sub

抓取上市交易明細程式碼如下
Option Explicit
Dim IE As Object, doc As Object, element As Object
Dim strURL As String, table As String, Pagecount As String, stockid As String, stockname As String

Const TempName As String = "Temp"
Public FilePath As String
Public Enum IE_READYSTATE
    READYSTATE_COMPLETE = 4
End Enum

Function 網頁開啟完成與否()
    網頁開啟完成與否 = False
    With IE
        '.Visible = True
        .Navigate "http://bsr.twse.com.tw/bshtm/bsMenu.aspx"
        Do While .Busy Or .ReadyState <> IE_READYSTATE.READYSTATE_COMPLETE
            DoEvents
        Loop
        
        Do
            DoEvents
        Loop Until .document.ReadyState = "complete"
    End With
    網頁開啟完成與否 = True
End Function

Sub 執行(pos As Integer, DownloadDate As String)
    Dim i As Integer, j As Integer, n As Integer, id As Integer
    
    Set IE = CreateObject("InternetExplorer.Application")
    If Not 網頁開啟完成與否 Then
        MsgBox "證交所買賣日報表查詢系統網頁無法開啟", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    With Sheet1
        n = .Cells(65536, 1).End(xlUp).Row
        For id = pos To n
            .Range("D2") = id
            stockid = .Cells(id, 1)
            stockname = .Cells(id, 2)
            
            取得明細
            
            Application.StatusBar = DownloadDate + " " + stockid + " " + stockname + "交易明細共有" + Pagecount + "頁"
            If Pagecount <> "" Then
                儲存CSV DownloadDate, stockid
                If SheetExists("Temp") Then
                    清除工作表 TempName
                End If
            End If
        Next
    
        If SheetExists("Temp") Then
            清除工作表 TempName
        End If
        
        .Activate
        .Range("D2") = 2
    End With
    IE.Quit
    
    Application.ScreenUpdating = True
    Set IE = Nothing
End Sub

Sub 取得明細()
    Dim i As Integer, j As Integer
    
    取得交易明細總頁數
    
    If Pagecount = "" Then Exit Sub
    
    strURL = "http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=" & stockid & "&FocusIndex=All_" + Pagecount
    
    If Pagecount > 655 Then
        MsgBox "股票編號" & stockid & "的總交易頁數超出工作表可以儲存的範圍"
        Exit Sub
    End If
    
    table = "5"
    For i = 0 To Pagecount + 1
        For j = 0 To 1
           table = table & "," & CStr(7 + 9 * i + j)
        Next j
    Next i
    
   If SheetExists(TempName) <> True Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = TempName   '建立指定工作到現存工作表的對後面
    Else
        清除工作表 TempName
    End If
   
    取得交易明細 strURL, table
    
    刪空特定列
    
End Sub

Sub 取得交易明細總頁數()
    Dim Retry As Integer
    Retry = 0
    
    Do
        Set doc = IE.document
    Loop While doc Is Nothing
    
    Do
        Pagecount = ""
        
        Do
            Do
                Set element = doc.getElementsByName("txtTASKNO")
            Loop While element Is Nothing
            
            element.Item(0).Value = stockid

            Set element = doc.getElementsByName("txtTASKNO")
        Loop While element.Item(0).Value <> stockid
        
        Do
            Do
                Set element = doc.getElementsByName("btnOK")
            Loop While element Is Nothing
            
            element.Item(0).Click
            
            Do
                Delay 0.5
                Set element = doc.getElementsByName("sp_ListCount")
            Loop While element Is Nothing
            
            Retry = Retry + 1
            If Retry = 10 Then Exit Sub
        Loop While element Is Nothing
        
        Delay 0.5
        Pagecount = element.Item(0).innerText
    Loop While Pagecount = ""

    Set doc = Nothing
    Set element = Nothing
End Sub

Sub 取得交易明細1(strURL As String, table As String)
    Dim xlSheet As Excel.Worksheet
    Set xlSheet = Sheets("Temp")

    With xlSheet.QueryTables.Add("URL;" & strURL, xlSheet.Cells(1, 1))
        .WebFormatting = xlWebFormattingNone
        .WebTables = table
        Do
            Delay 0.5
            On Error Resume Next
            .Refresh 0
            On Error GoTo 0
        Loop While Application.Count(.ResultRange) = 0
        .Delete
        'If Err.Number <> 0 Then Err.Clear: MsgBox Err.Number    '被免資料抓取不成功,而顯示訊息
        
    End With
End Sub

Sub 取得交易明細(strURL As String, table As String)
    Dim xlSheet As Excel.Worksheet
    Set xlSheet = Sheets("Temp")
    
Do
    Application.DisplayAlerts = False
    With xlSheet.QueryTables.Add("URL;" & strURL, xlSheet.Cells(1, 1))
        .WebFormatting = xlWebFormattingNone
        .WebTables = table
        On Error Resume Next
        Do
            Err.Clear
            .Refresh 0
            
            If Err.Number Then
                Application.Wait Now + TimeValue("00:00:01")
            End If
        
        Loop Until Err.Number = 0
        .Delete
        'If Err.Number <> 0 Then Err.Clear: MsgBox Err.Number    '被免資料抓取不成功,而顯示訊息
        On Error GoTo 0
    End With

    If Err.Number = 0 Then
        Application.DisplayAlerts = True
        Exit Sub
    End If
Loop
    
End Sub

Sub 刪空特定列()
    Dim i As Integer, j As Integer, Record As Integer
    
    Worksheets(TempName).Select
    Record = Cells(65536, 1).End(xlUp).Row
    j = 0
    For i = 6 To Record
        Rows(i & ":" & i).Select
        If ActiveCell.Value = Empty Or ActiveCell.Value = "序" Then
            j = j + 1
            Selection.EntireRow.Delete Shift:=xlUp
            If Record - j >= i Then
                i = i - 1
            End If
         End If
    Next
End Sub

Sub 儲存CSV(SaveDate As String, CSVname As String)
    Dim TestObj As Object
    Dim CSVfile As String, CSVfolder As String
    Dim TestFolder As Boolean

    CSVfolder = FilePath & SaveDate & "\"
    CSVfile = CSVfolder & CSVname & "_" & SaveDate & ".csv"
    
    Set TestObj = CreateObject("Scripting.FileSystemObject")
    TestFolder = TestObj.FolderExists(CSVfolder)
    If TestFolder = False Then TestObj.CreateFolder (CSVfolder)
        
    On Error Resume Next
    Kill CSVfile
    On Error GoTo 0
    
    Worksheets(TempName).Copy
    Application.DisplayAlerts = False
    With ActiveWorkbook
        .SaveAs Filename:=CSVfile, FileFormat:=xlCSV
        .Close 0
    End With
    Application.DisplayAlerts = True
End Sub

Function 清除工作表(xlWSName As String)
    Dim qyt As QueryTable
    With Worksheets(xlWSName)
        For Each qyt In .QueryTables
            qyt.Delete
        Next

        .Cells.Clear
        .Cells.ClearContents
    End With
End Function

Function SheetExists(strWSName As String) As Boolean
    Dim Temp As Worksheet
    On Error Resume Next
    Set Temp = Worksheets(strWSName)
    If Not Temp Is Nothing Then
        SheetExists = True
        On Error GoTo 0
        Exit Function
    End If
    SheetExists = False
    On Error GoTo 0
End Function

Function 刪除工作表(sheetname As String)
    Application.DisplayAlerts = False                    '關閉警告視窗
    Worksheets(sheetname).Select
    Worksheets(sheetname).Delete                            '刪除作用中的工作表
    Application.DisplayAlerts = True                     '恢復警告視窗
End Function

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


2 則留言:

  1. iInfo大大,
    VBA抓取上市交易明細的程式碼沒有找到 CommandButtom相關的程式碼. 懇求!能將檔案寄送給我參考嗎! 感恩~~~

    hotjoe888@hotmail.com

    回覆刪除
    回覆
    1. CommandButton你可自行添加

      目前有 "Excel VBA 投資數據存取" 課程,會敎基本的VBA語法
      有需要可以參考"Excel VBA 投資數據存取" http://white5168.blogspot.tw/2012/11/excel-vba.html

      刪除