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

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
お問い合わせ、個別連絡は、ブログ右下段のメールフォームから。

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

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

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

コメント

No title

こんにちは♪

自分でエクセルで表を作って何時間もかけて入力していました(T_T)
なのでホントにごく一部しか把握できないし、更新もごくたまにしか・・・
VBAできないのですがこれから勉強します!
情報ありがとうございますm(__)m
すぐには時間がなくできませんが、頑張ります!
お疲れ様でした(*'ω'*)

  • 2017/07/06 (Thu) 16:43
  • みょう #-
  • URL
Re: No title


みょうさん こんにちは

ネット上に私が作った『掲示番ランキング.xlsm』を保存しましたので、以下の方法で取りに行ってください。


http://firestorage.jp/download/3c158e37e2dd1e05d40157c3c7a98e3df785a036

手順
① 上記サイトを開く
② 『ダウンロードページを開く』の淡青色のボタンをクリックします。
③ ダウンロードパスワードを入力してください。と表示されるので、下記パスワードをコピペして、送信ボタンを押してください。

ダウンロードパスワード ddxdmngc

④柿色の『ダウンロード(44.37キロバイト)』のボタンをクリックしてください。ご自身のパソコンのダウンロードフォルダに保存されます。
⑤エクセルファイルを開く時にセキュリティー関係の許可や、マクロの有効化を求められるので、OKすれば使えるようになります。
⑥うまくいかないときは、コメントください。

それでは

  • 2017/07/06 (Thu) 17:19
  • キー坊 #-
  • URL
No title

早速ありがとうございます!
色々やってみたのですが上手くいかずお言葉に甘えてコメしてしまいました。

1、ダウンロード&開くまではできたのですが、ランキングページのコピペがよくわかりませんでした。
右クリックして、「すべて選択」してコピーしても、1位からずーっと範囲選択してコピーしても、「貼付けシート」のようになりませんでした。

2、とりあえず「貼付けシート」は元のままで、「ランキングシート」の左端に列を挿入して、「貼付けシート」の貼付けボタンを押してみましたら日時とランキングが転記されましたが色分けはされませんでした。

もう少し頑張ってみます。
お返事等はキー坊さんのお時間のある時で構いませんので、お気になさらないでくださいm(__)m
ありがとです(*'ω'*)

  • 2017/07/06 (Thu) 21:01
  • みょう #-
  • URL
No title

度々すみません。
ランキングのコピペは「すべて選択」でコピーして、無事「貼付けシート」に貼り付けることが出来ました!
で、貼付けボタンを押したのですが、やはり色分けだけはされませんでした。
ただ、「ランキングシート」の左端に列を挿入せずにボタンを押したのですが、自動的に転記された列が挿入されていました。
列を挿入してからボタンを押すと空白のB列が間に入ってしまうようです。
報告でしたm(__)m

色分けは私のエクセルで変換した時にマクロのプログラムが抜け落ちたのでしょうか。
わからないけどw
ちょっと勉強してみます。
とにかくこういう事が出来ることが感動です。
ありがとです(*^^)

  • 2017/07/06 (Thu) 21:30
  • みょう #-
  • URL
Re: No title

みょうさん こんばんは
以下ご質問に対する返答です。

■質問1、
ダウンロード&開くまではできたのですが、ランキングページのコピペがよくわかりませんでした。
右クリックして、「すべて選択」してコピーしても、1位からずーっと範囲選択してコピーしても、「貼付けシート」のようになりませんでした。

●返答1、
インターネットサイトを開いてコピペするのではなく、エクセルVBAで自動的に掲示板サイトを開いてコピーしてくるので、インターネットエクスプローラや掲示板サイトは一切扱う必要はありません。


■質問2
とりあえず「貼付けシート」は元のままで、「ランキングシート」の左端に列を挿入して、「貼付けシート」の貼付けボタンを押してみましたら日時とランキングが転記されましたが色分けはされませんでした。


●返答2
列の挿入も全てVBAで行うのでシートを触る必要はありません。行う作業はボタンをクリックするだけです。色分けはB列と比較して行うので、最初の貼付け時点では色分けはされません。
例えば7月5日のランキングが現在A列に100あるとします。翌日、貼付けボタンを押したら、7月5日のランキング銘柄はB列に移動し、新たにA列には7月6日のランキングが転記されます。

この時点で、前日のB列と本日のA列を比較してA列が色分けされます。


■質問3、
度々すみません。ランキングのコピペは「すべて選択」でコピーして、無事「貼付けシート」に貼り付けることが出来ました!
で、貼付けボタンを押したのですが、やはり色分けだけはされませんでした。
ただ、「ランキングシート」の左端に列を挿入せずにボタンを押したのですが、自動的に転記された列が挿入されていました。
列を挿入してからボタンを押すと空白のB列が間に入ってしまうようです。
報告でしたm(__)m

●返答3
返答2に同じです。行う作業は、ボタンをクリックすることのみです。


■質問4

色分けは私のエクセルで変換した時にマクロのプログラムが抜け落ちたのでしょうか。
わからないけどw
ちょっと勉強してみます。
とにかくこういう事が出来ることが感動です。
ありがとです(*^^)

●返答4
マクロは抜け落ちることはありません。とにかく、ボタンのみ押してください。他の作業は必要ありません。もしうまくいかないときには再度ご質問ください。お気遣いされなくて結構ですよ。

  • 2017/07/06 (Thu) 22:14
  • キー坊 #-
  • URL
No title

おはようございます。
ご丁寧にありがとうございました。
今朝ほど、何もせずボタンを押すのみで問題なく使用することできました。
毎日活用させて頂きつつ勉強していきますm(__)m

  • 2017/07/07 (Fri) 08:12
  • みょう #-
  • URL

コメントの投稿


管理者にだけ表示を許可する