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