最新消息

[公告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 案子開發需求,歡迎與我聯繫,可接案處理。

2012年10月14日 星期日

Excel VBA抓取股票代碼

使用QueryTables方法寫一個簡單的抓取上市櫃股票代碼,有興趣的可以參考。


抓取股票代碼完成畫面
VBA程式碼如下
Option Explicit

Dim Tempsheet As Excel.Worksheet
Private Sub 股票代碼_Click()
    抓取股票代碼
End Sub

Sub 抓取股票代碼()
    Dim StartTime
    
    StartTime = Now

    If 確認工作表存在("Temp") <> True Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
    End If
    清除工作表 ("Temp")
    清除工作表 ("Sheet1")
    
    Set Tempsheet = Sheets("Temp")
    
    Application.ScreenUpdating = False
    
    抓股票代碼
    解析股票代碼
    Application.ScreenUpdating = True
    
    MsgBox "股票代碼資料下載 共花費 " & Format(Now - StartTime, "HH時mm分ss秒") & " 下載完成。" & vbCrLf & "以秒計算 共花費 " & DateDiff("s", StartTime, Now) & " 秒下載完成", vbInformation
End Sub

Sub 解析股票代碼()
    Dim i As Integer, n As Integer
    With Sheet1
        .Cells(1, 1) = "股票代碼"
        .Cells(1, 2) = "公司名稱"
        n = 2
        With Tempsheet
            For i = 2 To .Cells(65536, 6).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 抓股票代碼()
    With Tempsheet.QueryTables.Add("URL;http://isin.twse.com.tw/isin/C_public.jsp?strMode=4", Tempsheet.Cells(1, 1)) 'strMode=2 上市  strMode=4 上櫃
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .Refresh 0
        If Err.Number <> 0 Then Err.Clear: MsgBox "資料查詢失敗"    '被免資料抓取不成功,而顯示訊息
        .Delete
    End With
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 確認工作表存在(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
如果覺得自己寫很麻煩,可至這裡下載

沒有留言:

張貼留言