最新消息

[公告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)失效導致頁面載入變慢,目前已做調整,請多見諒。

2013年9月8日 星期日

用VBA與3、5、10日均線向上找出多頭排列的上市股票

好久沒沒針對股票在找出一些相關的內容了,將我手邊可用的觀念來寫成一個利用VBA計算股票的3日、5日及10日均線的方法,來找出目前呈現多頭排列的上市股票,讓我們繼續看下去。
目前整份程式碼已經可以跑,不過時間就是比較久一點,還沒完全整理好,有興趣的可以自己花時間整理,後續在補充上櫃股票的部分。
Option Explicit

Sub 抓多頭排列()
    Dim i As Integer, n As String
    Dim xlWs
        
    Application.ScreenUpdating = False
   
    搜尋股票代碼
    
    'Application.StatusBar = "列出股票代碼,完成......"
    
    n = 9
    Set xlWs = Sheets("工作表1")
    For i = 414 To Sheets("TempStockid").Range("A65536").End(xlUp).Row
        If Not Sheets("TempStockid").Cells(i, 1) = 1470 Then
        
         If CheckSheetExist("Temp") <> True Then
             Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
         Else
             清除工作表 "Temp"
         End If
         
         Application.StatusBar = "找到 第" & n & " 個,目前正在確認 第" & i & "個" & Sheets("TempStockid").Cells(i, 1) & " " & Sheets("TempStockid").Cells(i, 2) & " 中"
         各股成交資訊 Sheets("TempStockid").Cells(i, 1)
         日均線計算
         
         If 抓出符合資料 = 1 Then
            n = n + 1
            Sheets("TempStockid").Range("A" & i & ":" & "B" & i).Copy xlWs.Range("A" & n & ":" & "B" & n)
            Sheets("Temp").Name = Sheets("TempStockid").Cells(i, 2)
         End If
        
         Application.StatusBar = "找到 第" & n & " 個,目前正在確認 第" & i & "個" & Sheets("TempStockid").Cells(i, 1) & " " & Sheets("TempStockid").Cells(i, 2) & " 完成......"
        End If
    Next
    
    Application.StatusBar = "共" & n & "個" & "符合...."
    Application.ScreenUpdating = True
    
    Set xlWs = Nothing
    
End Sub

Sub 搜尋股票代碼()
    Dim i As Integer
    Dim stockurl As String, xlstock As String
    Dim RowStart As Range, RowEnd As Range
    
    stockurl = "http://isin.twse.com.tw/isin/C_public.jsp?strMode=2"

    Application.ScreenUpdating = False
    
    If CheckSheetExist("TempStockid") <> True Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "TempStockid"
    Else
        清除工作表 "TempStockid"
    End If
    
    股票代碼 stockurl, "TempStockid"

    With Sheets("TempStockid")
        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
               
               xlstock = .Cells(i, 1)
                 .Cells(i, 1) = Split(xlstock, "  ")(0)
                 .Cells(i, 2) = Split(xlstock, "  ")(1)
                
            End If
        Next i
    End With
    
    刪空特定列
    Application.ScreenUpdating = True
    
End Sub

Sub 各股成交資訊(xlStockid As String)
    Dim xlURL As String, xlMon As String, xlYear As String
    Dim i As Integer, j As Integer, xlStartPos As String, xlDataCount As Integer, xlPos As String
    Dim xlTemp As Worksheet
   
    Set xlTemp = Sheets("Temp")
    xlTemp.UsedRange.Clear
    
    xlStartPos = 1
    xlPos = 0
    xlYear = Format(Year(Date), "0000")
    For i = 1 To Month(Date)
        xlMon = Format(i, "00")
        xlURL = "http://www.twse.com.tw/ch/trading/exchange/STOCK_DAY/STOCK_DAY_print.php?genpage=genpage/Report" & xlYear & xlMon & "/" & xlYear & xlMon & "_F3_1_8_" & xlStockid & ".php&type=csv"
        
        On Error Resume Next
        With Workbooks.Open(xlURL)
            xlDataCount = .Sheets(1).Range("A65536").End(xlUp).Row
            For j = 2 To 10
                If .Sheets(1).Cells(j, 1) = "日期" Then
                    xlPos = j + 1
                End If
            Next
            .Sheets(1).Range("A" & xlPos & ":I" & xlDataCount).Copy xlTemp.Cells(xlStartPos, 1)
            xlDataCount = xlDataCount - xlPos + 1
            xlStartPos = xlStartPos + xlDataCount
            .Close 0
        End With
        On Error GoTo 0
    Next
    
    Delay 1
    xlTemp.Select
    xlTemp.Range("A:I").Sort Key1:=Range("A:A"), Order1:=xlDescending
    
    Set xlTemp = Nothing

End Sub

Sub 日均線計算()
    'http://www.k1simplify.com/vba/tipsleaf/leaf23.html
    Dim xlRowCount As Integer, xlColumnPos As Integer
    Dim i As Integer, j As Integer, n As Integer
    Dim xlAveragerDay
    
    xlAveragerDay = Array(3, 5, 10)
    
    n = 0
    Sheets("Temp").Select
    n = Sheets("Temp").Cells(1, 256).End(xlToLeft).Column
    xlRowCount = Sheets("Temp").Range("A65536").End(xlUp).Row
    
    For i = 0 To UBound(xlAveragerDay)
        For j = 1 To xlRowCount - xlAveragerDay(i)
            Cells(j, n + 1 + i) = Application.Average(Range("g" & j & ":" & "g" & (j + xlAveragerDay(i) - 1)))
        Next j
    Next i
    
End Sub

Function 抓出符合資料()

Dim xlRowCount As Integer, xlFind As Integer
Dim i As Integer, j As Integer, n As Integer

xlRowCount = Sheets("Temp").Range("A65536").End(xlUp).Row
n = Sheets("Temp").Cells(1, 256).End(xlToLeft).Column
On Error Resume Next

For i = 1 To xlRowCount
    If Cells(i, 10) > Cells(i, 11) Then
        Cells(i, n + 1) = 1
    Else
        Cells(i, n + 1) = 0
    End If
    
    If Cells(i, 10) > Cells(i, 12) Then
        Cells(i, n + 2) = 1
    Else
        Cells(i, n + 2) = 0
    End If
    
    If Cells(i, 11) > Cells(i, 12) Then
        Cells(i, n + 3) = 1
    Else
        Cells(i, n + 3) = 0
    End If
    
    Cells(i, n + 4) = Cells(i, n + 1) * Cells(i, n + 2) * Cells(i, n + 3)
Next i

xlFind = 1
For i = 1 To 10
    n = Sheets("Temp").Cells(i, 256).End(xlToLeft).Column
    xlFind = xlFind * Cells(i, n)
Next i

On Error GoTo 0

抓出符合資料 = xlFind

End Function

Sub 刪空特定列()
    Dim i As Integer, j As Integer, Record As Integer
    
    With Worksheets("TempStockid")
        .Cells(1, 1).Select
        Record = Cells(65536, 1).End(xlUp).Row
        j = 0
        For i = 1 To Record
            Rows(i & ":" & i).Select
             If Not Trim(.Cells(i, 6)) = "ESVUFR" And _
                   Not Trim(.Cells(i, 6)) = "EUOMSR" And _
                   Not Trim(.Cells(i, 6)) = "EMXXXA" And _
                   Not Trim(.Cells(i, 6)) = "ESVUFA" Then
                j = j + 1
                Selection.EntireRow.Delete Shift:=xlUp
                If Record - j >= i Then
                    i = i - 1
                End If
             End If
        Next
    End With
End Sub

Sub 股票代碼(StockIDURL As String, xlSheetName As String)
    Dim xlSheet As Excel.Worksheet
    Set xlSheet = Sheets(xlSheetName)
    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

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 CheckSheetExist(strWSName As String) As Boolean
    Dim Temp As Worksheet
    On Error Resume Next
    Set Temp = Worksheets(strWSName)
    If Not Temp Is Nothing Then
        CheckSheetExist = True
        On Error GoTo 0
        Exit Function
    End If
    CheckSheetExist = False
    On Error GoTo 0
End Function

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


1 則留言:

  1. 版主您好,看過您的部落格支後,心中真的很欽佩,真的是太強了..........

    回覆刪除