(11)「tp11-今日の値動き」今日の値動き/詳細情報の掲載仕様変更に伴う対処方法
Yahooファイナンスの「今日の値動き」が2012/8/15からテーブルから文章に仕様変更があり対応（2012/8/16）
▼▼▼▼▼▼▼▼ Module2 ▼▼▼▼▼▼▼▼
変数型宣言部
【変更前】
Public Const URLY As String = "http://quote.yahoo.co.jp/q?s="
・・・・・・・・・・
Dim itmsu As Integer
【変更後】
Public Const URLY As String = "http://stocks.finance.yahoo.co.jp/stocks/detail/?code="
Dim itmsu As Integer
Dim dat2() As String ’← 追加
Dim rck As Integer ’← 追加
-----------------------------------------------------------------------------
【変更前】
Sub kabu1a()
shurui = "&d=v2&k=c3&h=on&z=m"
sheetn = "今日の値動き"
Call kabu2
Call プログレス初期化
End Sub
Sub kabu1b()
shurui = "&d=v3&k=c3&h=on&z=m"
sheetn = "財務指標"
Call kabu2
Call プログレス初期化
End Sub
【変更後】
Sub kabu1a()
sheetn = "今日の値動き"
dast = 10000
ReDim dat2(10) As String
Call kabu2
Call プログレス初期化
End Sub
Sub kabu1b()
sheetn = "詳細情報"
dast = 30000
ReDim dat2(30) As String
Call kabu2
Call プログレス初期化
End Sub
-------------------------------------------------------------------------------
【変更後】 Sub kabu2()は以下に変えて下さい
Sub kabu2()
Application.ScreenUpdating = False
過去データ削除
endr = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
endc = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
Range(Cells(1, 2), Cells(endr, endc)).ClearContents
シート名変更
Sheets(ActiveSheet.Name).Name = sheetn
On Error Resume Next
cend1 = meino(0)
If Err = 9 Then
MsgBox "リストの指定がありません。"
Exit Sub
ElseIf Err <> 0 Then
MsgBox "予期せぬエラー発生"
Exit Sub
End If
On Error GoTo 0
hazime = 0: urlka = "": pg = 0
For i = 1 To cend1
urlk = URLY & meino(i)
プログレス
Call 今日財務取得
Next
表示整備
Columns("B:B").ColumnWidth = 16.88
Columns("E:E").ColumnWidth = 12.5
Columns("J:J").ColumnWidth = 12.5
End Sub
----------------------------------------------------------------------------
Sub 今日財務取得()
【変更後】
Dim oHttp As Object
・・・・・・・・・・・・
.Pattern = ">([^<>]+)<"
.Global = True
On Error Resume Next
・・・・ ここまでは同じでstchk1 = 以降は下記に変えて下さい・・・・・・・・・
stchk1 = InStr(1, dthtml, "リアルタイム株価", 1)
rck = 0
If stchk1 > 21000 Or stchk1 = 0 Then '2013/2月変更 20000→ 21000
stchk1 = InStr(1, dthtml, "20分ディレイ株価", 1)
rck = 1
End If
If stchk1 = 0 Then
ReDim hdat(7)
Else
dthtml = Mid$(dthtml, stchk1 - 50, dast)
With .Execute(dthtml)
ccc = .Count
ReDim hdat(ccc)
jb = 0
For j = 1 To ccc - 1
hdat(j) = .Item(j + jb).SubMatches(0)
Next j
End With
On Error GoTo 0
End If
End With
If hdat(7) = "" Then
ReDim dat2(30) As String
dat2(0) = meino(i)
dat2(1) = "※データ取得失敗※"
Call 貼付け
Exit Sub
End If
dat2(0) = meino(i)
dat2(1) = hdat(7)
dat2(2) = hdat(1)
For ib = 10 To 150
If hdat(ib) = "前日比" Then dat2(3) = hdat(ib - 2)
If hdat(ib) = "前日比" Then dat2(4) = hdat(ib + 1)
If hdat(ib) = "前日終値" Then dat2(5) = hdat(ib - 3)
If hdat(ib) = "始値" Then dat2(6) = hdat(ib - (4 - rck))
If hdat(ib) = "高値" Then dat2(7) = hdat(ib - (4 - rck))
If hdat(ib) = "安値" Then dat2(8) = hdat(ib - (4 - rck))
If hdat(ib) = "出来高" Then dat2(9) = hdat(ib - 4)
Next
If dast = 30000 Then
For ib = 150 To 400
If hdat(ib) = "時価総額" Then dat2(10) = hdat(ib - (5 - rck))
If hdat(ib) = "発行済株式数" Then dat2(11) = hdat(ib - 4)
If hdat(ib) = "配当利回り" Then dat2(12) = hdat(ib - (5 - rck))
If hdat(ib) = "1株配当" Then dat2(13) = hdat(ib - 3)
If hdat(ib) = "PER" Then dat2(14) = hdat(ib - (5 - rck))
If hdat(ib) = "PBR" Then dat2(15) = hdat(ib - (5 - rck))
If hdat(ib) = "EPS" Then dat2(16) = hdat(ib - 3)
If hdat(ib) = "BPS" Then dat2(17) = hdat(ib - 3)
If hdat(ib) = "最低購入代金" Then dat2(18) = hdat(ib - (4 - rck))
If hdat(ib) = "単元株数" Then dat2(19) = hdat(ib - 3)
Next
End If
Set oHttp = Nothing
Call 貼付け
End Sub
----------------------------------------------------------------
【変更後】 Sub 貼付け()は以下に変えて下さい
Sub 貼付け()
Dim da(19)
Dim dsu As Integer
da(0) = "コード": da(1) = "名称": da(2) = "時刻": da(3) = "現株価": da(4) = "前日比"
da(5) = "前日終値": da(6) = "初値": da(7) = "高値": da(8) = "安値": da(9) = "出来高"
da(10) = "時価総額": da(11) = "発行済株式数": da(12) = "配当利回り": da(13) = "1株配当"
da(14) = "PER": da(15) = "PBR": da(16) = "EPS": da(17) = "BPS"
da(18) = "最低購入代金": da(19) = "単元株数"
If hazime = 0 Then
hazime = 1
'表題の貼り付け
If sheetn = "詳細情報" Then
Worksheets(sheetn).Select
For ia = 0 To 19
Cells(1, ia + 1) = da(ia)
Next
Else
Worksheets(sheetn).Select
For ia = 0 To 9
Cells(1, ia + 1) = da(ia)
Next
End If
End If
最終セル
cend2 = Cells(10000, 2).End(xlUp).Row + 1
If sheetn = "詳細情報" Then
For ia = 0 To 19
Cells(cend2, ia + 1) = dat2(ia)
Next
Else
For ia = 0 To 9
Cells(cend2, ia + 1) = dat2(ia)
Next
End If
End Sub