掲示番ランキング上昇銘柄

7月 第4日 
本日確定損益 ▲30万円
当月確定損益 130万円

今日は負けました。しかし、恒例のRIZAPの裁量空売りは今日もやりました。祭りは昨日で終わった、と思いきや、まだまだ見せ場を作ってくれますね。パスポートと、ジンズメイトがS高に貼り付いていましたが、そのいずれかが剥がれたら全体が崩れるだろうと思い、待っていたら、1時頃ジンズメイトがはがれたので、マルコに空売りを546円で仕掛け2時前に519円(利益5%)で手仕舞いました。

2000株×27円で54000円の勝ち、今楽天では、1日信用での仕掛けが100万円以上の場合、7月末まで金利0でやっているので、実質上記が利益でした。RIZAP銘柄はしこり玉で上値は重いと思っての仕掛けです。


さて、本題に入って、今日は若干エクセルのVBAができる方を対象に記事を書いています。ヤフー掲示板のtextreamに各銘柄の投稿数ランキング100があります。

≪こちらhttps://textream.yahoo.co.jp/ranking/finance≫

この上位にあるのは、現在注目が集まっている銘柄です。
そこで、毎日変動するランキングをエクセルで管理したいなと思っていました。そして管理シートを作りました。

これをなぜ作ったかですが、このランキングを眺めていても、上位の銘柄は印象に残るのですが、下位にある銘柄が日々どのくらい上昇したのか(人気化したのか)が客観的にわかりません。それを可視化して、相場感覚を養うためです。

ランキング管理

このエクセルシートで下からランキングを上げている銘柄が分かります。5以上ランキングが上がったものはベージュ、10以上は黄色、20位以上は赤で色分けされます。
作業は毎日一定時刻にエクセルを開き貼付けボタンを押すだけです。IEを立ち上げたり、コピペしたりは不要です。約10秒前後で終了します。

以下にコードを乗せますのでVBAのできる方で興味があれば、コピペして使ってください。

■コード
Sub 貼付け()

Dim objIE As Object
Dim url As String
Dim rng As Range
Dim i As Integer
Dim j As Integer
Dim diff As Integer 'ランキング差を格納

On Error Resume Next
Application.ScreenUpdating = False

'テクストリームサイトよりランキング情報を取得します。
Set objIE = CreateObject("InternetExplorer.application")

objIE.Visible = False

objIE.Navigate "https://textream.yahoo.co.jp/ranking/finance"

While objIE.readyState <> 4 Or objIE.Busy = True
DoEvents
Wend
'ページを全選択、コピーし、IEを閉じます。
objIE.ExecWB 17, 0
objIE.ExecWB 12, 0
objIE.Quit
Set objIE = Nothing

'貼付けシートにランキング銘柄を貼りつけます。
Sheets("貼付け").Cells.Clear
Sheets("貼付け").Range("A1").Select
ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True

'ランキングシートの左端に新しい列を作ります。
Sheets("ランキング").Columns(1).Insert
Sheets("ランキング").Range("A1") = Now
Sheets("ランキング").Columns("A").ColumnWidth = 22

'ランキングシートのA列にランキング銘柄を転記します。
j = 2

For i = 1 To 100
Sheets("ランキング").Cells(j, 1).Value = Sheets("貼付け").Cells(Sheets("貼付け").Range("A:A").Find(What:=i, LookAt:=xlWhole).Row + 2, 1).Value
j = j + 1
Application.StatusBar = "銘柄転記中---" & i
Next

Sheets("ランキング").Select

'上昇5以上ベージュ、10~19に黄色、20以上に赤を色付けします。
For i = 2 To 101

diff = i - Range("A:A").Find(What:=Cells(i, 2)).Row

If diff >= 5 And diff < 10 Then
Range("A:A").Find(What:=Cells(i, 2)).Interior.ColorIndex = 36
ElseIf diff >= 10 And diff < 20 Then
Range("A:A").Find(What:=Cells(i, 2)).Interior.ColorIndex = 6
ElseIf diff >= 20 Then
Range("A:A").Find(What:=Cells(i, 2)).Interior.ColorIndex = 3
End If

Next

Range("A1").Select
Beep
End Sub

■作成方法
①エクセルに『ランキング』と『貼付け』というシートを作ります。
②『貼付け』シートにフォームボタンを配置して、プロシージャ『貼付け』を登録します。

■ボタン押下後の動作
①インターネットエクスプローラで、掲示板ランキングのURLを開きランキングページがコピーされる。(IEは不可視で開くので、画面上は表示されません。)
②コピーされたランキング銘柄が自動的にエクセルの『貼付け』シートに貼り付けられる。
③『ランキング』シートの左端に列が1つ挿入される。
④挿入された列に貼付けられた銘柄が1番から100番まで転記される。
⑤ランキング上昇幅により色分けされる。

■注意
①使用上の責任は一切負いません。
②ヤフー掲示板の表示形式や、URLが変わったときは機能しなくなります。その場合はご自身でコードを修正してください。
③初回貼付け時は、比較するものが無いので色分けはされません。
④ご自身のパソコンにインターネットエクスプローラがインストールされている必要があります。
⑤ご不明な点はコメントください。

ポチっとしていただき、パチ(拍手)して頂くとやる気モリモリです。m(__)m
お問い合わせ、個別連絡は、ブログ右下段のメールフォームから。

株式システムトレード ブログランキングへ
にほんブログ村 株ブログ 株 自動売買へ
にほんブログ村

株システムトレードソフトイザナミ

株システムトレードのトレジスタ・ストラテジーオンライン
スポンサーサイト