![見出し画像](https://assets.st-note.com/production/uploads/images/145942664/rectangle_large_type_2_aaa5a2fa17d1fba112b14fa50c56408c.jpeg?width=1200)
楽天RSS×ExcelVBA OVER/UNDER時系列データの作り方
はじめに
皆さんこんにちは。
今回は楽天RSSとExcel VBAを用いた、OVERとUNDERの時系列データを記録するプログラムのアップデート版のご紹介をしていきます。
以前作成した動画はこちらになります。
今回作成するプログラムの完成イメージはこちらになります。
今回はできるだけ自動化を目指しました。
Excelの準備
1.新しいファイルの作成
マクロ有効ブックの".xlsm"で保存します。
2.シートの作成
今回3つのシートを作成します。
名称は「設定」、「検索」、「銘柄」としました。
・設定のシートでは、取得間隔と最終更新時間があります。
取得間隔はプログラムを特定の間隔で実行して、OVERとUNDERのデータを記録します。
最終更新時間はトリガーの役割を持ちます。
![](https://assets.st-note.com/img/1719899837297-aPN8CaExQj.png?width=1200)
・検索のシートでは、特定の銘柄のOVERとUNDERをグラフで閲覧できます。
検索ボタンを押すとプログラムが実行され、設定されている間隔でデータの記録をするプログラムが実行されます。
初期化ボタンを押すとシートを削除します。
![](https://assets.st-note.com/img/1719900043916-ViCkgYwxw7.png?width=1200)
・銘柄のシートでは、記録した銘柄を500銘柄分記録しています。
銘柄の証券コードはこちらの東証上場銘柄一覧を参考にしています。
![](https://assets.st-note.com/img/1719900231293-h1lIQCUjzE.png?width=1200)
プログラムの記述
標準モジュールと検索シートに下記のコードを入力します。
下記プログラムでは9:00:00~15:00:00までの間で動作するようにしています。そのため、テストする際は Const END_TIME As String = "15:00:00"の時間を適宜変更してください。
1.標準モジュール
標準モジュールを挿入して、下記コードをコピペします。
![](https://assets.st-note.com/img/1719901094902-XtKp75UMxv.png?width=1200)
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セルの証券コードが変更されたときに再更新します。
![](https://assets.st-note.com/img/1719901166744-R2Snv6Uu7g.png?width=1200)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
ExtractAndDisplayData
End If
End Sub
最後に
お疲れ様です。
これで一度実行してみましょう。
無事に動作していれば、完成となります!
この記事が気に入ったらサポートをしてみませんか?