最新消息

[公告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月13日 星期六

Excel VBA抓取股票資料

使用QueryTables方法寫一個簡單的上市櫃股票的所有基本資料。


抓取交易明細完成畫面
VBA程式碼如下
Option Explicit

'股票類別
'01 水泥工業
'02 食品工業
'03 塑膠工業
'04 紡織纖維
'05 電機機械
'06 電器電纜
'07 化學生技醫療
'08 玻璃陶瓷
'09 造紙工業
'10 鋼鐵工業
'11 橡膠工業
'12 汽車工業
'13 電子工業
'14 建材營造
'15 航運業
'16 觀光事業
'17 金融保險業
'18 金融保險業
'19 綜合企業
'20 其他
'21 化學工業
'22 生技醫療業
'23 油電燃氣業
'24 半導體業
'25 電腦及週邊設備業
'26 光電業
'27 通信網路業
'28 電子零組件業
'29 電子通路業
'30 資訊服務業
'31 其他電子業

Dim Tempsheet As Excel.Worksheet

Private Sub 更新股票資料_Click()
    抓取股票基本資料
End Sub

Sub 抓取股票基本資料()
    Dim n As Integer
    Dim StartTime
    
    StartTime = Now

    If 確認工作表存在("Temp") <> True Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
    End If
    
    清除工作表 ("Sheet1")
    清除工作表 ("Temp")
    
    Application.ScreenUpdating = False
    
    Set Tempsheet = Sheets("Temp")
    
    If 取得股票資料 = 0 Then
        MsgBox "無法抓取股票資料"
        Exit Sub
    End If
  
    Application.StatusBar = "正在轉換資料,請稍後......"
    
    With Sheet1
        .Cells(1, 1) = "股票代碼"
        .Cells(1, 2) = "公司名稱"
        
        n = 取得公司間數
        Tempsheet.Range("A1:B" & n).Copy    '目前只列出股票代碼、公司名稱,如有需要其他欄位,請自行變更
    
        .Cells(2, 1).Select
        .Paste
    End With
    
    Application.StatusBar = "股票基本資料抓取完成"
    Application.ScreenUpdating = True
    
    MsgBox "股票基本資料下載 共花費 " & Format(Now - StartTime, "HH時mm分ss秒") & " 下載完成。" & vbCrLf & "以秒計算 共花費 " & DateDiff("s", StartTime, Now) & " 秒下載完成", vbInformation

End Sub

Sub 清除工作表(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 Sub

Function 取得公司間數()
    Dim i As Integer, j As Integer, n As Integer
    j = 0
    取得公司間數 = 0
    With Tempsheet
        n = .Cells(65536, 1).End(xlUp).Row
        For i = 1 To n
            If .Cells(i, 1).Value = Empty Or _
               .Cells(i, 1).Value = "代號" Or _
               .Cells(i, 1).Value = "公司" Then
                j = j + 1
                .Rows(i & ":" & i).Delete Shift:=xlUp
                If n - j >= i Then
                    i = i - 1
                End If
             End If
        Next
        取得公司間數 = .Cells(65536, 1).End(xlUp).Row
    End With
End Function

Function 取得股票資料()
    Dim xlURL As String
    
    Application.StatusBar = "從Web取得股票資料中,請稍後......"
    
    xlURL = "http://mops.twse.com.tw/mops/web/ajax_t51sb01?step=1&firstin=1&TYPEK=sii" '上市 sii, 上櫃 otc
    With Tempsheet.QueryTables.Add("URL;" & xlURL, Tempsheet.Cells(1, 1))
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .Refresh 0
        If Application.Count(.ResultRange) = 0 Then
            取得股票資料 = 0
            Exit Function
        End If
        取得股票資料 = Application.Count(.ResultRange)
        .Delete
    End With
End Function

Function 確認工作表存在(xlWSName As String) As Boolean
    On Error Resume Next
    Dim xlTemp As Excel.Worksheet
    
    Set xlTemp = Worksheets(xlWSName)
    If Not xlTemp Is Nothing Then
        確認工作表存在 = True
        On Error GoTo 0
        Set xlTemp = Nothing
        Exit Function
    End If
    
    確認工作表存在 = False
    On Error GoTo 0
    Set xlTemp = Nothing
End Function
如果覺得自己寫很麻煩,可至這裡下載

沒有留言:

張貼留言