用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