楽天RSS×ExcelVBA OVER/UNDER時系列データの作り方

StockLink360

2024年7月2日 15:23

はじめに

皆さんこんにちは。
今回は楽天RSSとExcel VBAを用いた、OVERとUNDERの時系列データを記録するプログラムのアップデート版のご紹介をしていきます。

以前作成した動画はこちらになります。

今回作成するプログラムの完成イメージはこちらになります。

今回はできるだけ自動化を目指しました。

Excelの準備

1.新しいファイルの作成

マクロ有効ブックの".xlsm"で保存します。

2.シートの作成

今回3つのシートを作成します。
名称は「設定」、「検索」、「銘柄」としました。

・設定のシートでは、取得間隔と最終更新時間があります。
取得間隔はプログラムを特定の間隔で実行して、OVERとUNDERのデータを記録します。
最終更新時間はトリガーの役割を持ちます。

・検索のシートでは、特定の銘柄のOVERとUNDERをグラフで閲覧できます。
検索ボタンを押すとプログラムが実行され、設定されている間隔でデータの記録をするプログラムが実行されます。
初期化ボタンを押すとシートを削除します。

・銘柄のシートでは、記録した銘柄を500銘柄分記録しています。
銘柄の証券コードはこちらの東証上場銘柄一覧を参考にしています。

プログラムの記述

標準モジュールと検索シートに下記のコードを入力します。
下記プログラムでは9:00:00～15:00:00までの間で動作するようにしています。そのため、テストする際は Const END_TIME As String = "15:00:00"の時間を適宜変更してください。

1.標準モジュール
標準モジュールを挿入して、下記コードをコピペします。

Sub TimeSet()
    Const INTERVAL_CELL As String = "A2"
    Const START_TIME As String = "09:00:00"
    Const END_TIME As String = "15:00:00"
    Const SETTING_SHEET As String = "設定"
    
    Dim interval As String
    Dim startTime As Date
    Dim endTime As Date
    Dim currentTime As Date
    Dim intervalSeconds As Long
    Dim hours As Long
    Dim minutes As Long
    Dim seconds As Long
    Dim timeParts() As String

    ' 設定シートのA2セルから時間間隔を取得
    interval = Worksheets(SETTING_SHEET).Range(INTERVAL_CELL).Text

    ' 時間間隔を分解して時間、分、秒に変換
    timeParts = Split(interval, ":")
    If UBound(timeParts) = 2 Then
        hours = CLng(timeParts(0))
        minutes = CLng(timeParts(1))
        seconds = CLng(timeParts(2))
        intervalSeconds = (hours * 3600) + (minutes * 60) + seconds
    Else
        MsgBox "時間間隔は 'HH:MM:SS' 形式で入力してください。"
        Exit Sub
    End If

    ' 開始時刻と終了時刻を設定
    startTime = TimeValue(START_TIME)
    endTime = TimeValue(END_TIME)

    ' OnTimeを設定
    currentTime = startTime
    Do While currentTime <= endTime
        ' 指定した時間にCheckAndRunTaskを実行
        Application.OnTime currentTime, "CheckAndRunTask"
        ' 次の実行時間を設定
        currentTime = DateAdd("s", intervalSeconds, currentTime)
    Loop
End Sub

Sub CheckAndRunTask()
    Const SETTING_SHEET As String = "設定"
    Const LAST_RUN_TIME_CELL As String = "B2"
    
    Dim lastRunTime As String
    Dim currentTime As String
    Dim ws As Worksheet
    
    ' 設定シートを取得
    Set ws = Worksheets(SETTING_SHEET)
    
    ' B2セルから最後に実行した時間を取得
    lastRunTime = ws.Range(LAST_RUN_TIME_CELL).Text
    ' 現在の時間をフォーマットして取得
    currentTime = Format(Now, "hh:mm:ss")

    ' 現在の時間が最後に実行した時間と異なる場合にのみ実行
    If lastRunTime <> currentTime Then
        ' 現在の時間をB2セルに記録
        ws.Range(LAST_RUN_TIME_CELL).Value = currentTime
        ' スケジュールされたタスクを実行
        RunScheduledTask
    End If
End Sub

Sub RunScheduledTask()
    Dim currentTime As String
    ' 現在の時間をフォーマットして取得
    currentTime = Format(Now, "hh mm ss")
    ' 現在の時間を名前とするシートを作成
    CreateSheet currentTime
    ' 新しく作成したシートに銘柄シートのデータをコピー
    CopyDataToSheet currentTime
    ' データの抽出と表示
    ExtractAndDisplayData
    ' グラフの更新
    UpdateChartRange
End Sub

Sub CreateSheet(sheetName As String)
    Dim originalSheet As Worksheet
    Dim newSheet As Worksheet
    
    ' 現在のアクティブシートを保存
    Set originalSheet = ActiveSheet
    
    On Error Resume Next
    ' 指定した名前のシートが存在しない場合に新しいシートを作成
    If Not WorksheetExists(sheetName) Then
        Set newSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        newSheet.Name = sheetName
    Else
        ' シートが存在する場合はそのシートを取得
        Set newSheet = Worksheets(sheetName)
    End If
    On Error GoTo 0
    
    ExtractAndDisplayData
    
    ' 元のアクティブシートに戻す
    originalSheet.Activate
End Sub

Sub CopyDataToSheet(sheetName As String)
    ' 新しく作成したシートに銘柄シートのデータをコピー
    Worksheets(sheetName).Range("A1:E500").Value = Worksheets("銘柄").Range("A1:E500").Value
End Sub

Sub ExtractAndDisplayData()
    Dim code As String
    Dim ws As Worksheet
    Dim destSheet As Worksheet
    Dim currentRow As Long
    Dim cell As Range
    
    ' "検索"シートのA2セルからコードを取得
    code = Worksheets("検索").Range("A2").Value
    
    ' 以前のデータをクリア
    With Worksheets("検索")
        .Range("A5:D1000").ClearContents
    End With
    
    currentRow = 5
    
    ' 全てのシートをループしてデータを抽出
    For Each ws In ThisWorkbook.Worksheets
        ' シート名がカスタムタイムシート形式かどうかを確認
        If IsCustomTimeSheet(ws.Name) Then
            ' コードを検索
            Set cell = ws.Columns("A").Find(What:=code, LookIn:=xlValues, LookAt:=xlWhole)
            If Not cell Is Nothing Then
                With Worksheets("検索")
                    ' シート名（時間）をA列に記録
                    .Cells(currentRow, 1).Value = ws.Name
                    ' B列のOVERを転記
                    .Cells(currentRow, 2).Value = cell.Offset(0, 2).Value
                    ' C列のUNDERを転記
                    .Cells(currentRow, 3).Value = cell.Offset(0, 3).Value
                    ' D列のO/Uを転記
                    .Cells(currentRow, 4).Value = cell.Offset(0, 4).Value
                End With
                currentRow = currentRow + 1
            End If
        End If
    Next ws
End Sub

Function IsCustomTimeSheet(sheetName As String) As Boolean
    Dim parts() As String
    parts = Split(sheetName, " ")
    If UBound(parts) = 2 Then
        If IsNumeric(parts(0)) And IsNumeric(parts(1)) And IsNumeric(parts(2)) Then
            If Len(parts(0)) = 2 And Len(parts(1)) = 2 And Len(parts(2)) = 2 Then
                IsCustomTimeSheet = True
                Exit Function
            End If
        End If
    End If
    IsCustomTimeSheet = False
End Function

Function WorksheetExists(sheetName As String) As Boolean
    Dim sheet As Worksheet
    WorksheetExists = False
    For Each sheet In Worksheets
        If sheet.Name = sheetName Then
            WorksheetExists = True
            Exit Function
        End If
    Next sheet
End Function

Sub DeleteNumericSheets()
    Dim sheet As Worksheet
    Dim sheetName As String
    Dim i As Integer
    
    ' 逆ループを使用してシートを削除する
    ' これにより、削除時のインデックスずれを防ぐ
    For i = ThisWorkbook.Worksheets.Count To 1 Step -1
        Set sheet = ThisWorkbook.Worksheets(i)
        sheetName = sheet.Name
        
        ' シート名がカスタムタイムシート形式かどうかを判定する
        If IsCustomTimeSheet(sheetName) Then
            Application.DisplayAlerts = False
            sheet.Delete
            Application.DisplayAlerts = True
        End If
    Next i
    
    'データの初期化
    ExtractAndDisplayData
End Sub

Sub UpdateChartRange()
    Dim ws As Worksheet
    Dim chartObj As ChartObject
    Dim chart As chart
    Dim lastRow As Long
    
    ' データが含まれるシートを設定
    Set ws = Worksheets("検索")
    
    ' データの最終行を取得 (ここではA列の最終行を取得)
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' シート上の最初のグラフオブジェクトを取得
    If ws.ChartObjects.Count > 0 Then
        Set chartObj = ws.ChartObjects(1)
        Set chart = chartObj.chart
    Else
        MsgBox "グラフが見つかりません", vbExclamation
        Exit Sub
    End If
    
    ' 各シリーズのデータ範囲を更新
    With chart.SeriesCollection(1) ' OVERシリーズ
        .Values = ws.Range("B5:B" & lastRow)
        .XValues = ws.Range("A5:A" & lastRow)
    End With
    
    With chart.SeriesCollection(2) ' UNDERシリーズ
        .Values = ws.Range("C5:C" & lastRow)
        .XValues = ws.Range("A5:A" & lastRow)
    End With
    
    With chart.SeriesCollection(3) ' O/Uシリーズ
        .Values = ws.Range("D5:D" & lastRow)
        .XValues = ws.Range("A5:A" & lastRow)
        .AxisGroup = xlSecondary ' 第2軸に設定
        .ChartType = xlLine ' 折れ線に変更
    End With
    
    ' 第1軸の設定
    With chart.Axes(xlValue, xlPrimary)
        .HasTitle = True ' 軸ラベルを表示
        .AxisTitle.Text = "値"
    End With
    
    ' 第2軸の設定
    With chart.Axes(xlValue, xlSecondary)
        .HasTitle = True ' 軸ラベルを表示
        .AxisTitle.Text = "O/U"
    End With
End Sub

2.検索シート
検索シートをダブルクリックして、選択し、下記コードをコピペします。
A2セルの証券コードが変更されたときに再更新します。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$A$2" Then
        ExtractAndDisplayData
    End If
End Sub

最後に

お疲れ様です。
これで一度実行してみましょう。
無事に動作していれば、完成となります！

この記事が気に入ったらサポートをしてみませんか？