株価をチェックして、安値高値でサウンドを再生

ちなみにヤフーファイナンスでも安値、高値に達したらメールで知らせてくれるサービスは存在するが、メールを見ないといけないし、複数の銘柄をチェックする場合は面倒になってくる。エクセルシートを見ながら、再生音で安値、高値をチェックできたら便利と思った。

エクセルを複数起動したい場合は、Windowキー＋Rファイルを指定して起動で[excel /x]と入力して起動させて、エクセルブックを開けばよい。

仕様
楽天証券、マーケットスピード、RSS.exeが必要。Windowsのみ。
VBAによるループ処理で、現在値と安値、高値を比較します。
DoEvntsでイベントを受け付けます。
安値、高値になるとサウンドが1回再生されます。達成チェック列（H2以降）の文字を消すと再度再生します。サウンドファイルは個別に用意をする必要があります。
コードを入力後は銘柄ボタンをクリックしないと株価を取得しません。

参考にしたサイト

https://dp-invest.hateblo.jp/entry/2020/11/09/192427

使い方

（１）コードを入力して銘柄ボタンをクリックすると銘柄名と株価を取得します。
（２）安値と高値を入力します。省略可能。
（３）チェック開始ボタンで比較実行
（４）終了ボタンで処理を停止

Public goFlag
Public endFlag
Sub mycolor(cell As String)
'
' color Macro
'マクロの記録で作成

'
    Range(cell).Select
    With Selection.Font
        .color = -16776961
        .TintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
End Sub
Sub colorBack(cell As String)
'
' colorBack Macro
'

'
    With Selection.Font
        .color = -16776961
        .TintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveCell.FormulaR1C1 = ""
    Range(cell).Select
    Range(cell).Value = ""
    
End Sub


Sub meigara()
'https://dp-invest.hateblo.jp/entry/2020/11/09/192427
'を参考にした

Dim i As Integer
Dim n, m As Integer
Dim code

n = Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To n 'A2から以降のコード
    code = Cells(i, 1)
    If code <> "" Then
        Cells(i, 2).Value = "=RSS|'" & code & ".T’!銘柄名称"
        Cells(i, 3).Value = "=RSS|'" & code & ".T’!現在値"
    Else '
        Cells(i, 2).Value = "" 'B cell
        Cells(i, 3).Value = "" 'C
        Cells(i, 8).Value = "" 'H cell
    End If

Next i

m = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To m
    If Cells(i, 1) = "" Then
        Cells(i, 2).Value = "" 'B cell
        Cells(i, 3).Value = "" 'C
        Cells(i, 4).Value = "" 'D
        Cells(i, 6).Value = "" 'F
        Cells(i, 8).Value = "" 'H cell
        colorBack ("H" & i)
    End If
Next i

m = Cells(Rows.Count, "D").End(xlUp).Row
For i = 2 To m
    If Cells(i, 1) = "" Then
        
        Cells(i, 4).Value = "" 'D
        Cells(i, 6).Value = "" 'F
        Cells(i, 8).Value = "" 'H cell
        colorBack ("H" & i)
    End If
Next i

End Sub
Sub endCheck()
    Range("E14").Value = "停止"
    endFlag = False
    Debug.Print "end"
    MsgBox "株価チェック終了しました"
End Sub

Sub kabuCheckAlert() 'チェック開始ボタンで実行
    '株価をチェックして、指定した値に達したら警告音やアラートを表示する
    Dim t As Long
    Dim nTime As Long
    Dim n As Integer
    Dim strYasune
    Dim strTakane
    endFlag = True 'falseで処理を終わる
    nTime = 3
    t = Timer
    strYasune = "安値です"
    strTakane = "高値です！！"
    'H列を空欄にする
    m = Cells(Rows.Count, "H").End(xlUp).Row
    For i = 2 To m
        Range("H" & i).Value = ""
    Next i
    
    meigara
   Range("E14").Value = "実行中"
    Do
        DoEvents
     '------Start Timer
        If t + nTime < Timer Then '秒単位のタイマー　Timeは時刻nTimeで指定した秒間隔でコピー処理を行う
            Debug.Print nTime&; "秒間隔　株価チェック　実行中"
            t = Timer
            'nTime毎に株価をチェックする
            'ここを行数分ループする
            n = Cells(Rows.Count, "A").End(xlUp).Row
            'For next Start
            For i = 2 To n
                If Range("C" & i).Value <> "" And Range("D" & i).Value <> "" Then
                    If Range("C" & i).Value <= Range("D" & i).Value Then
                        If Range("H" & i).Value <> strYasune Then 'Hセルが空のときだけ再生し、すでにHセルに記載があれば音を再生しない
                            Debug.Print "株価が安値に達しました"
                            Range("H" & i).Value = strYasune
                            mycolor ("H" & i)
                            Shell "C:\Program Files\Windows Media Player\wmplayer.exe C:\Users\mased\Music\ヒューンと落下.mp3", 1
                        End If
                    End If
                    
                End If
                If Range("C" & i).Value <> "" And Range("F" & i).Value <> "" Then
                    If Range("C" & i).Value >= Range("f" & i).Value Then
                        If Range("H" & i).Value <> strTakane Then 'Hセルが空のときだけ再生し、すでにHセルに記載があれば音を再生しない
                            Debug.Print "株価が高値に達しました"
                            Range("H" & i).Value = strTakane
                            mycolor ("H" & i)
                            Shell "C:\Program Files\Windows Media Player\wmplayer.exe C:\Users\mased\Music\決定、ボタン押下37.mp3", 1
                        End If
                    End If
                End If
            Next i
            'For next end
        End If
     '----End Timer
     
        If endFlag = False Then
            Debug.Print "exit loop"
            Range("E14").Value = "停止"
            Exit Do
        End If
    Loop
    Debug.Print "End"
End Sub