(13)「tp12-株価比較」今日の値動き/詳細情報の掲載仕様変更に伴う対処方法
Yahooファイナンスの「今日の値動き」が2012/8/15からテーブルから文章に仕様変更があり対応（2012/8/17）
以下マクロの「灰色ステータス」を削除し、「オレンジステータス」に変える。
▼▼▼▼▼▼▼▼ Module11 ▼▼▼▼▼▼▼▼
Public Const URLY As String = "http://quote.yahoo.co.jp/q?s="
Public Const URLY As String = "http://stocks.finance.yahoo.co.jp/stocks/detail/?code="
--------------------------------------------------------------------------
Sub 財務指標()
Dim urlka As String
・・・・・・・・・・・・・・・・・・・・・・・・
j = 0 ここまではそのまま使用
*********** 実行 ******************
urlka = ""
For sh = 1 To koodo(0, 0)
If j = 0 Then
urlka = URLY & koodo(0, sh)
Else
・・・・・・・・・・・・
Application.StatusBar = ""
End Sub
++++++++++++ 上記 urlka = "" 〜End Sub を削除して下記を貼り付け +++++++++
*********** 実行 ******************
urlka = ""
For sh = 1 To koodo(0, 0)
urlk = URLY & koodo(0, sh)
Call 財務取得
Next
Application.StatusBar = ""
End Sub
--------------------------------------------------------------------------
Sub 財務取得()
Application.StatusBar = "市場取得中--" & cend2 + 50
Call 今日財務取得
'取得チェック
If hdat(1) <> "自動更新" Then
MsgBox "市場コード付加に失敗しました"
Exit Sub
End If
End Sub
--------------------------------------------------------------------------
Sub 今日財務取得()
Dim chk As Integer
Dim oHttp As Object
・・・・・・・・・・・・・・・・・・・・・・・・・・・
With CreateObject("VBScript.RegExp")
.Pattern = ">([^<>]+)<"
.Global = True
ここまではそのまま残す。
stchk1 = InStr(1, dthtml, "名称", 1)
stchk2 = InStrRev(Left(dthtml, stchk1), "table")
・・・・・・・・・・・・・・・・・・・・・・・・・・・
Call 財務貼付
End Sub
++++++++++++ 上記 stchk1 = 〜End Sub を削除して下記を貼り付け +++++++++
On Error Resume Next
stchk1 = InStr(1, dthtml, "自動更新", 1)
dthtml = Mid$(dthtml, stchk1 - 50, 10000)
With .Execute(dthtml)
jb = 0
For j = 1 To 600
hdat(j) = .Item(j + jb).SubMatches(0)
Next j
End With
On Error GoTo 0
End With
dat2(0) = hdat(13)
dat2(1) = hdat(15)
dat2(2) = hdat(25)
Call 財務貼付
End Sub
--------------------------------------------------------------------------
++++++++++++ Sub 財務貼付()プロシージャは 下記に変える +++++++++
Sub 財務貼付()
Sheets("財務指標").Select
最終セル
cend2 = Cells(10000, 2).End(xlUp).Row + 1
For ia = 0 To 2
Cells(cend2, ia + 1) = dat2(ia)
Next
End Sub
--------------------------------------------------------------------------
市場
・・・・・・・・・・・・
ElseIf InStr(1, sizyo(1, i), "JASDAQ", 1) > 0 Then
Cells(i + 1, 3) = "Q"
ElseIf InStr(1, sizyo(1, i), "JQS", 1) > 0 Then
Cells(i + 1, 3) = "Q"
▼▼▼▼▼▼▼▼ Module21 ▼▼▼▼▼▼▼▼
本日データの追加は「Module21」モジュールソースを改善しますが、今までの「Module21」を削除して、
tp16-鍋蓋足チャート
で作成した「Module21」をそのまま使用して下さい。ただし下記の変更が必要です。
行空け
Sheets(shname).Select
Rows("4:4").Select
Selection.Insert Shift:=xlDown
行空け
Sheets("仮データ").Select
Rows("2").Insert Shift:=xlDown
貼付
For i = 1 To 5
Cells(4, i + 1) = da(i)
Next
Cells(4, 1) = Date
貼付
For i = 1 To 5
Cells(2, i + 1) = da(i)
Next
Cells(2, 1) = Date
--------------------------------------------------------------------------
(14)「tp17-信用倍率」infoseekの掲載終了に伴うYahooファイナンスへ変更方法
はじめてメールさせていただきます。
「新・ＥｘｃｅｌＶＢＡで極めるシステムトレード」を購入させて頂きました。付属のＤｉｓｃをインストールし「信用倍率」
の項目をアドインさせていただいたのですが、デバックが起こります。
ＶＢＡのどの記述を変更しなければいけないのかお教えいただけませんでしょうか？（2012/11/28)
著者の回答としては、「Infoseek マネー」は、2011年12月17日（土）をもって終了しました。
したがって、Infoseekのデータを使用させて頂いていたツールは実行できません。サイトの閉鎖であり著者としては、
ツールを改善して対処できる問題でないので対象のツールは使用不可です。
しかし、「信用倍率」はYahooファイナンスからも取得可能であり、使用不可で済ませるのは購入読者に対して
不親切なので、Yahooファイナンス使用のツール「tp17a-sinyou」を作成したのでこちらを使用して下さい。
「tp17a-sinyou」ダウンロ−ド(44kb)
なお、このマクロにはプロテクトがかかっています。外す場合は、280ページの図8-2-2bの実行例図の表に
A列にコードがありますが、そのコードの3行目のコード番号****の4桁の数字でプロテクトは解除されます。
【追記】
大証が東証に統合された頃「信用倍率」のURLが変更になりました。上記は2013/8/22日更新しました。
(15)「tp18-保有日数カレンダー」今日の値動きのYahooファイナンス仕様変更に伴う対処方法
今日の値動きのYahooファイナンス仕様変更は終了していましたが、HPに公開するのを忘れていました。失礼しました。
Module4の内容を全て削除して下記を貼り付けて下さい。
▼▼▼▼▼▼▼▼ Module4 ▼▼▼▼▼▼▼▼
Public Const urly As String = "http://stocks.finance.yahoo.co.jp/stocks/detail/?code="
Dim urlk As String 'Web接続先
Dim cend1 As Integer 'リスト最終セル
Dim cend2 As Integer '記録最終セル
Dim i As Integer
Dim j As Integer
Dim da() As String
Dim hdat() As String
Dim rck As Integer
Sub 本日追加()
urlk = urly & meino1 & basho
Call 正規今日
'取得チェック
If hdat(1) = "" Then
MsgBox "今日の値動きの追加に失敗しました"
Exit Sub
End If
' -----------------------------------------------------------------
'出来高0チェック
If IsNumeric(da(1)) = False Then
MsgBox "現在出来高0で追加できません"
Exit Sub
End If
'行空け
Sheets(bshet).Select
Rows(4).Insert Shift:=xlDown
'貼付
Cells(4, 1) = Date
Cells(4, 2) = da(0)
Range("G1").Select
End Sub
Sub 正規今日()
Dim chk As Integer
Dim oHttp As Object
Dim dthtml As String
Dim j As Long
Dim jb As Integer
ReDim hdat(160)
Set oHttp = CreateObject("Microsoft.XMLHTTP")
With CreateObject("VBScript.RegExp")
.Pattern = ">([^<>]+)<"
.Global = True
oHttp.Open "GET", urlk, False
oHttp.Send
dthtml = oHttp.responsetext
stchk = 1
On Error Resume Next
stchk1 = InStr(1, dthtml, "リアルタイム株価", 1)
rck = 0
If stchk1 > 21000 Or stchk1 = 0 Then
stchk1 = InStr(1, dthtml, "20分ディレイ株価", 1)
rck = 1
End If
If stchk1 <> 0 Then
dthtml = Mid$(dthtml, stchk1 - 50, 10000)
With .Execute(dthtml)
jb = 0
For j = 1 To 150
hdat(j) = .Item(j + jb).SubMatches(0)
Next j
End With
End If
On Error GoTo 0
End With
'データを配列へ
ReDim da(1)
For ib = 10 To 150
If hdat(ib) = "前日比" Then
da(0) = hdat(ib - 2) '現在値
End If
If hdat(ib) = "出来高" Then
If IsNumeric(hdat(ib - 4)) = False Then
da(1) = 0
Else
da(1) = hdat(ib - 4)
End If
End If
Next
Set oHttp = Nothing
End Sub
(16)「tp12-株価比較」詳細情報のYahooファイナンス仕様変更に伴う対処方法
Yahooファイナンスの「詳細情報」が2014/5/20から掲載フォームに仕様変更があり対応（2014/5/21）
以下マクロの「灰色ステータス」を削除し、「オレンジステータス」に変える。
▼▼▼▼▼▼▼▼ Module11 ▼▼▼▼▼▼▼▼
'取得チェック
' If hdat(1) <> "自動更新" Then
If hdat(5) <> "こちら" Then
---------------------------------------------
' stchk1 = InStr(1, dthtml, "自動更新", 1)
stchk1 = InStr(1, dthtml, "現在JavaScript", 1)
---------------------------------------------
' dat2(0) = hdat(13) 'コード
' dat2(1) = hdat(15) '市場
' dat2(2) = hdat(25) '銘柄
dat2(1) = hdat(13) '市場
If Len(hdat(45)) = 4 Then
dat2(0) = hdat(45) 'コード
ElseIf Len(hdat(46)) = 4 Then
dat2(0) = hdat(46) 'コード
ElseIf Len(hdat(47)) = 4 Then
dat2(0) = hdat(47) 'コード
ElseIf Len(hdat(48)) = 4 Then
dat2(0) = hdat(48) 'コード
End If
---------------------------------------------
' sizyo(2, i - 1) = Cells(i, 3)
'銘柄
' If mtuika = 1 Then
' Cells(i + 1, 2) = sizyo(2, i)
' End If
(17)「tp12-株価比較」詳細情報のYahooファイナンス再仕様変更に伴う対処方法
Yahooファイナンスが再仕様変更になったので、前（16）項の1部を下記に変更して下さい（2014/6/03）
以下マクロの「灰色ステータス」を削除し、「オレンジステータス」に変える。
▼▼▼▼▼▼▼▼ Module11 ▼▼▼▼▼▼▼▼
dat2(1) = hdat(13) '市場
If Len(hdat(45)) = 4 Then
dat2(0) = hdat(45) 'コード
ElseIf Len(hdat(46)) = 4 Then
dat2(0) = hdat(46) 'コード
ElseIf Len(hdat(47)) = 4 Then
dat2(0) = hdat(47) 'コード
ElseIf Len(hdat(48)) = 4 Then
dat2(0) = hdat(48) 'コード
End If
dat2(1) = hdat(13) '市場
For i = 43 To 48
If Len(hdat(i)) = 4 Then
dat2(0) = hdat(i) 'コード
Exit For
End If
Next