2007/07/22 ExcelVBA/ITIckerから一定条件下の銘柄を抽出する
サイトのリニューアルに伴い、内容の一部を書き換えたり追加したりしました。
過去の記事は左側ボックスのリンクをクリックして進んでください。
2007/05/17
上場されている銘柄の中から自分にとって都合のよい条件を満たす銘柄を抽出する。
このページの要約
- コア銘柄を除いて個別銘柄の人気は流動的である
- 一定条件を満たすにぎやかな銘柄をリストする
- 価格帯別の銘柄リストも見てみたかった
- 例によってITIckerとExcelVBA＋ＳＱＬで実現
流動性のある上位銘柄を定期的に選別する
今回のExcelVBAの目的は、 ITIckerのmdbファイルから任意の銘柄レコードを抜き出して一定条件を満たす銘柄をリストすることです。
東証はじめ全国の証券取引所に上場されている銘柄は、正確にはわかりませんが４千銘柄を超えるようです。 これほどの上場銘柄数があっても取引が活発でない銘柄もありますし、近寄らないほうが無難な銘柄も存在します。 流動性が確保できていつでも取引が行われている、そこそこ出来高のある銘柄群を確保しておきたい。 そう考えて定期的にリストするようにしていました。
当初、単純に（擬似的な）売買代金のみで抽出していましたが、当日だけ値が異常に大きい銘柄もあり得ます。 これらの凸凹をならすためには平均を出して比較してみるほかありません。 比較といえば、平均代金の何倍もの売買代金に至っている銘柄は人気が集中している、とも判断できます。
出来高や売買代金だけでは抽出にひっかからない、或いはひっかかってしまう銘柄もあります。 最低取引単位が大きすぎる銘柄などです。 これらは除外する必要がある銘柄なので別途除外専用シートを準備しました。 基本的な仕様としては、一定期間の平均値を算出して平均代金を計算するとともに、 代金と平均代金を併用してふるい落とすこととしました。 ふるい落とす絞込み条件は下記のようなものです。
- 売買代金
- 平均代金
- 除外銘柄
売買代金は当日出来高と終値を掛けたものですから擬似的な値となります。
平均代金は一定期間を対象とします。
これは厳密にｘ日必要ということではなくて１００日未満の任意の日数でかまわないでしょう。
除外銘柄は別シートにリストをつくりそこに掲載した銘柄は除外するようにします。
各シートの部品
1円から299円、300円から999円、というふうに８個の価格帯別にシートを準備します。
私の任意で決めた範囲ですからこれ自体には意味はありません。
最初の時点ではどの価格帯にどのくらいの銘柄が存在するのかは把握していませんでしたから
この結果は相性という観点からある意味役にたっています。
シートセルデータ領域の項目は共通です。
各シート見出し
一時計算シート
シートセルデータ領域の項目
除外銘柄シート
結果シート
結果シートに取得できたリストは抽出条件にもよりますが、今現時点でのにぎやか銘柄です。 代金や平均代金で並べ替えしてみるとよくわかります。 倍率で飛びぬけている銘柄があればそれはお祭り銘柄でしょう。
抽出する目的
各銘柄には個別の株価があり常に変動しています。
しかし１０００円前後の株価がいきなり５万円にはなりません。
一定の幅の間で上下を繰り返すのが普通です。
そこで株価の価格帯別のリストをみてみたくなりました。
要はどの価格帯にはどんな銘柄があるのだろうか？という疑問を解消したかったからです。
これが何に役立ったのか？と問われると、あまり役にはたっていません！と答えるしかありません。
残念なことに一般的な知識程度のものでしょう。
仕組み事態は至って簡単です。ＳＱＬを使えば一定範囲の株価を絞り込むことは難しくありません。
それぞれの結果（レコードセット）を個別シートに転記するだけです。
転記された個別株価帯シートのコードをもとに、ITIckerから再度期間データを読み出してやり、
今度は平均代金と倍率を計算し該当銘柄の該当セルに書き戻します。 この処理にはやや時間がかかります。
平均計算のために仮に８０日間の個別株価を読み出したらそれだけでも時間のかかる処理となってしまいますが、これはやむを得ません。
以上の処理が終わると最後の結果シートへの転記を実行して完了します。
結果シートには、売買代金と平均代金で絞り込んだ銘柄のリストが残ります。
私の場合には都合で、６００銘柄なり９００銘柄に近い数の銘柄が残るように調整して使っています。
抽出するための仕組み
抽出するための道具立ては次のとおりです。
- ITIcker
- ExcelSheet
- VBA + SQL
シートは上記の図にもあるように株価帯別に複数用意しておきます。
[To299]から[100000To]、[除外リスト]などです。
抽出結果は[sheet2]に転記されます。私は別のブックに結果だけ書き出しています。
ひとつのブック内に結果シートを保持してもかまわないでしょう。
シートの順番については For 〜 Next で指定している箇所があるため、
[To299]→→→[除外リスト]→[Temporary]→[sheet2]の順にしておいてください。
ITIckerのmdbファイルからＳＱＬで抽出したデータをシートに読み出します。 読み出したcodeをもとに再度該当銘柄の該当期間を[Temporary]シートに読み出して 平均計算した結果を個別銘柄の該当箇所へ戻しています。 この部分をシートから配列変数に変更してみましたが速度的には大した変化はありませんでした。
リスト
リストが少々長くなってしまいました。
なお、自分だけしか使わないという前提であったためユーザーフォームはありませんし、
エラー処理もありません。その点ご了承下さい。
これらのリストは区切り線の、１●、２●、３●、をそれぞれＦ５キーで直接実行してやる必要があります。
上記の図にあるシートをすべて用意すれば多分下記のVBAを貼り付けるだけで動作するとは思います。
なお、結果シート[sheet2]はVBAを実行する前に、毎回手動で消去しておく必要があります。
消去しないと新しいレコードが追加されてしまいます。
（ADOの参照設定は必要です。）
Option Explicit
Private sname As String
Private sid As Long
Private eid As Long
'
' Ｆ５キーでこのSubプロシージャを実行する。
' ("To299")以降のシートをクリアし、新たに銘柄とデータを読み出す処理。
' １●ここを実行すると「平均代金」は再計算する必要がある。
Sub jikko()
Worksheets("To299").Select
sname = "To299": sid = 0: eid = 299
Call kobetu
sname = "300To999": sid = 301: eid = 999
Call kobetu
sname = "1000To1499": sid = 1000: eid = 1499
Call kobetu
sname = "1500To1999": sid = 1500: eid = 1999
Call kobetu
sname = "2000To3000": sid = 2000: eid = 3000
Call kobetu
sname = "3001To9999": sid = 3001: eid = 9999
Call kobetu
sname = "10000To99999": sid = 10000: eid = 99999
Call kobetu
sname = "100000To": sid = 100000: eid = 99999999
Call kobetu
'--- 除外銘柄のみ別扱い
sname = "除外リスト": sid = 1: eid = 99999999
Call kobetu除外
End Sub
'ITickerから指定した個別シートに展開する
Sub kobetu()
Dim myCon As ADODB.Connection
Dim myRS As ADODB.Recordset
Dim r As Long
'----------------------------------------------------------------
myCon.Open _
"provider=Microsoft.jet.oledb.4.0;" & _
"Data Source=C:\Program Files\SoftREED\ITicker\ITickerJ.mdb;"
'----------------------------------------------------------------
Set myRS = New ADODB.Recordset
r = Worksheets(sname).Range("B2").End(xlDown).Row '最終列番号
r = IIf(r = 65536, 2, r)
Worksheets(sname).Range("B2:K" & r) = Null 'データ領域消去
'----- ＳＱＬ処理 ------------
With myRS
.ActiveConnection = myCon
'--- 取込制限： ---
'--- sell2=売買代金 unit=売買単位 unit*valend=最低売買代金(xxx万円)
.Source = "SELECT market,chr(39) & code,name,valend,sell/10000,sell2/100000,unit,unit*valend FROM code " & _
"WHERE market IN ('JASDAQ','ヘラクレス','マザーズ','東証1部','東証2部','大証1部','大証2部') " & _
"AND valend>=" & sid & " AND valend<=" & eid & " " & _
"AND code NOT IN ('1320','1321','9511','9508','9509','9506','9507','9504','9501','9502','9503','9505'," & _
"'7974','6861','9661','8830','7733','8802','4452','8801','1742','9873','5214','7287','6975','7731'," & _
"'7752','5214','7287','6975','7731','7752','6976','6366','6349','4911','6247','6752','4313','JASDAQ') " & _
"AND sell>0 " & _
"AND valend>=100 " & _
"ORDER BY valend DESC"
.Open
End With
'----- [銘柄]シートに書き出す処理 ------------
Worksheets(sname).Range("B2").CopyFromRecordset myRS
Set myRS = Nothing
Set myCon = Nothing
End Sub
Sub kobetu除外()
Dim myCon As ADODB.Connection
Dim myRS As ADODB.Recordset
Dim r As Long
Set myCon = New ADODB.Connection
'----------------------------------------------------------------
myCon.Open _
"provider=Microsoft.jet.oledb.4.0;" & _
"Data Source=C:\Program Files\SoftREED\ITicker\ITickerJ.mdb;"
'----------------------------------------------------------------
Set myRS = New ADODB.Recordset
r = Worksheets(sname).Range("B2").End(xlDown).Row '最終列番号
r = IIf(r = 65536, 2, r)
Worksheets(sname).Range("B2:K" & r) = Null 'データ領域消去
'Range(Cells(2, 1), Cells(r, 25)).Delete 'データ領域削除
'----- ＳＱＬ処理 ------------
With myRS
.ActiveConnection = myCon
.Source = "SELECT market,chr(39) & code,name,valend,sell/10000,sell2/100000,unit,unit*valend FROM code " & _
"WHERE market IN ('東証1部','東証2部','大証1部','大証2部') " & _
"AND valend>=" & sid & " AND valend<=" & eid & " " & _
"AND code IN ('1320','1321','9511','9508','9509','9506','9507','9504','9501','9502','9503','9505'," & _
"'7974','6861','9661','8830','7733','8802','4452','8801','1742','9873','5214','7287','6975','7731'," & _
"'7752','5214','7287','6975','7731','7752','6976','6366','6349','4911','6247','6752','4313') " & _
"ORDER BY valend DESC"
.Open
End With
'----- [銘柄]シートに書き出す処理 ------------
Worksheets(sname).Range("B2").CopyFromRecordset myRS
Set myRS = Nothing
Set myCon = Nothing
End Sub
Option Explicit
'--- 指定したシートの[平均代金]と[倍率]を２シートに転記する
'
' ２●("To299")をアクティブにしておいてからＦ５キーで実行する
'
Sub test()
Dim tmp As String
Dim i As Integer
Dim StName As String
Worksheets("To299").Select
For i = 1 To Worksheets.Count - 3
Worksheets(i).Select
StName = Worksheets(i).Name
'Debug.Print StName
tmp = StDataWrit(StName)
Next i
End Sub
'--- 対象シート名を渡して基になるシートから処理結果を対象シートに書き出す
'
Function StDataWrit(StName As String) As String
Dim myCon As ADODB.Connection
Dim myRS As ADODB.Recordset
Dim r As Long
Dim TblName As String 'データベース名
Dim i As Integer
Dim dt As String '遡る日付
Dim CdName As String 'コード
Dim nMs As Long '[銘柄]シートの最終行位置
Dim heikin As Double '平均代金
Dim myRange As Range 'レンジ
nMs = Worksheets(StName).Range("B2").End(xlDown).Row '[]シート最終行番号
nMs = IIf(nMs = 65536, 2, nMs)
'--- [StName]シート上のcodeを拾う
For i = 2 To nMs
Worksheets("Temporary").Range("A1") = nMs - i + 1 '処理No
Worksheets(StName).Range("A1") = nMs - i + 1 '処理No
''Debug.Print nMs - i + 1
CdName = Worksheets(StName).Range("C" & i) '銘柄コード取得
TblName = cdselect(CdName) 'cdselect関数でテーブル名取得
''If TblName = "" Then Exit For
'--- 日数は実営業日ではなく本日までの経過日数となる
dt = Format(DateAdd("d", -100, Date), "yyyy/m/d") 'xxx日前からの日付を割り出す
Set myCon = New ADODB.Connection
'---------------------------------------------------------
myCon.Open _
"provider=Microsoft.jet.oledb.4.0;" & _
"Data Source=C:\Program Files\SoftREED\ITicker\HistDBJ\" & TblName & ";"
'---------------------------------------------------------
Set myRS = New ADODB.Recordset
r = Worksheets("Temporary").Range("B4").End(xlDown).Row '[Temporary]シート最終列番号
r = IIf(r = 65536, 4, r)
Worksheets("Temporary").Range("B4:I" & r) = Null
'----- ＳＱＬ処理 ------------
With myRS
.ActiveConnection = myCon
'--- 個別銘柄の取り込み： ---------------------------------
.Source = "SELECT code,date,valend,valstart,valhight,vallow,sell/10000,(sell*valend)/100000000 FROM data " & _
"WHERE code='" & CdName & "' " & _
"AND date> #" & dt & "# " & _
"ORDER BY date DESC"
.Open
End With
'----- [Temporary]シートに書き出す処理 ------------
Worksheets("Temporary").Range("B4").CopyFromRecordset myRS
r = Worksheets("Temporary").Range("B4").End(xlDown).Row '[Temporary]シート最終列番号
r = IIf(r = 65536, 4, r)
'--- [StName]シートに書き戻す処理 -------------------
With Worksheets(StName)
Set myRange = Worksheets("Temporary").Range("I4:I" & r) '１銘柄の期間
heikin = Application.WorksheetFunction.Average(myRange) '１銘柄期間の平均
Worksheets("Temporary").Range("I2") = heikin '[I2]=平均
.Range("J" & i) = heikin '[StName]シートに平均代金を書き出す
.Range("K" & i) = .Range("G" & i) / .Range("J" & i) '代金平均倍率
End With
Set myRS = Nothing
Set myCon = Nothing
Next i
StDataWrit = StName
End Function
'--- ３●転記先：Ｆ５キーで実行する
'--- 関数tenkib()を呼び出す
'--- 指定条件を満たす銘柄を転記する
'--- 転記先：「sheet2」が必要
'--- 転記元：[To299] 〜 [3001To9999]シート
Sub tenkia()
Dim tmp As Integer
Worksheets("To299").Select
tmp = tenkib("To299", 1)
tmp = tenkib("300To999", tmp)
tmp = tenkib("1000To1499", tmp)
tmp = tenkib("1500To1999", tmp)
tmp = tenkib("2000To3000", tmp)
tmp = tenkib("3001To9999", tmp)
End Sub
'--- 実行手順：tenkia()から呼ばれる
'--- 転記先：「sheet2」が必要
'--- 転記元：[To299] 〜 [3001To9999]シート
'--- 平均代金か当日代金がx億円以上の銘柄を転記する。
Function tenkib(cd As String, cn As Integer) As Integer
Dim i As Integer
Dim nMs As Long
Dim StName As String
Dim NCount As Integer
Dim cnt As Integer
StName = cd
nMs = Workbooks("ITicker読出し.xls").Worksheets(StName).Range("B2").End(xlDown).Row '[]シート最終行番号
nMs = IIf(nMs = 65536, 2, nMs)
cnt = cn
For i = 2 To nMs
'
' G=代金/億円>x億円 J=平均代金>x億円 下記は抽出条件である
'
If Workbooks("ITicker読出し.xls").Worksheets(StName).Range("G" & i) >= 1 And _
Workbooks("ITicker読出し.xls").Worksheets(StName).Range("J" & i) >= 1 Then
NCount = NCount + 1
cnt = cnt + 1
'
' BからKの範囲をコピーする
'
Workbooks("ITicker読出し.xls").Worksheets(StName).Range("B" & i & ":K" & i).Copy _
Destination:=Workbooks("ITicker件数内訳.xls").Worksheets("sheet2").Range("B" & cnt)
End If
Next i
nMs = Workbooks("ITicker件数内訳.xls").Worksheets("sheet2").Range("B2").End(xlDown).Row '[]シート最終行番号
nMs = IIf(nMs = 65536, 2, nMs)
tenkib = nMs
Debug.Print NCount, nMs
End Function
'銘柄コードの値によって所属データベース名を返す
Function cdselect(cd As String) As String
Dim nb As String
Select Case cd
Case 1000 To 1499
nb = "01.mdb"
'Debug.Print "1000 から 1499 の間"
Case 1500 To 1999
nb = "02.mdb"
'Debug.Print "1500 から 1999 の間"
Case 2000 To 2499
nb = "03.mdb"
'Debug.Print "2000 または 2499"
Case 2500 To 2999
nb = "04.mdb"
'Debug.Print "2500 または 2999"
Case 3000 To 3499
nb = "05.mdb"
'Debug.Print "3000 または 3499"
Case 3500 To 3999
nb = "06.mdb"
'Debug.Print "3500 または 3999"
Case 4000 To 4499
nb = "07.mdb"
'Debug.Print "4000 または 4499"
Case 4500 To 4999
nb = "08.mdb"
'Debug.Print "4500 または 4999"
Case 5000 To 5499
nb = "09.mdb"
'Debug.Print "5000 または 5499"
Case 5500 To 5999
nb = "10.mdb"
'Debug.Print "5500 または 5999"
Case 6000 To 6499
nb = "11.mdb"
'Debug.Print "6000 または 6499"
Case 6500 To 6999
nb = "12.mdb"
'Debug.Print "6500 または 6999"
Case 7000 To 7499
nb = "13.mdb"
'Debug.Print "7000 または 7499"
Case 7500 To 7999
nb = "14.mdb"
'Debug.Print "7500 または 7999"
Case 8000 To 8499
nb = "15.mdb"
'Debug.Print "8000 または 8499"
Case 8500 To 8999
nb = "16.mdb"
'Debug.Print "8500 または 8999"
Case 9000 To 9499
nb = "17.mdb"
'Debug.Print "9000 または 9499"
Case 9500 To 9999
nb = "18.mdb"
'Debug.Print "9500 または 9999"
Case Else
nb = ""
'Debug.Print "範囲外の数値"
End Select
cdselect = nb '戻り値
End Function
赤字の部分は各自の環境にあわせて変更してください。
"Data Source=C:\Program Files\SoftREED\ITicker\ITickerJ.mdb;"
冗長な部分もあるのでもっと短く簡潔に書けるかもしれません。
興味のあるかたがおられたら挑戦してみてください。
記述の間違いなどあればご指摘いただけるとありがたいです。
投資は自己責任でお願いします。抽出された結果をもとにいかなる損失が発生しても当方は関知しません。
管理人へのメッセージ