■table.yahoo.co.jp 株価時系列データ取得2

# 1 の続き...

Sub getXML(ByVal rng As Range, ByVal dDate As Date)
　　Dim dTMP　As Date　　　'検索開始Date
　　Dim xml　 As Object　　'MSXML2.ServerXMLHTTP
　　Dim reg　 As Object　　'VBScript.RegExp
　　Dim mc　　As Object　　'RegExp.Match
　　Dim ws　　As Worksheet '書き出しSheet
　　Dim flg　 As Boolean　 'SheetCheck, LoopOut判定FLG
　　Dim url　 As String　　'URLアドレス
　　Dim ret　 As String　　'XMLHTTP.responsetext
　　Dim st(7) As String　　'URL構成文字列
　　Dim cd　　As String　　'コード用文字列
　　Dim r　　 As Range　　 'rngLoop用
　　Dim dCHK　As Date　　　'LoopOut判定用
　　Dim dX　　As Long　　　'期間日数
　　Dim po(2) As Long　　　'chk文字存在判定
　　Dim x　　 As Long　　　'HTML項目Loop用
　　Dim cnt　 As Long　　　'データCOUNT
　　Dim i　　 As Long
　　Dim j　　 As Long
　　Dim k　　 As Long
　　Dim n　　 As Long
　　Dim v, w

　　On Error GoTo errHndlr
　　Set xml = CreateObject("MSXML2.ServerXMLHTTP")
　　Set reg = CreateObject("VBScript.RegExp")
　　reg.Pattern = PTN
　　reg.Global = True
　　'STARTDAYより多目
　　dTMP = DateAdd("d", -10, STARTDAY)
　　st(1) = "c=" & Year(dTMP)
　　st(2) = "a=" & Month(dTMP)
　　st(3) = "b=" & Day(dTMP)
　　st(4) = "f=" & Year(dDate)
　　st(5) = "d=" & Month(dDate)
　　st(6) = "e=" & Day(dDate)
　　st(7) = "g=d&q=t&y="
　　'期間日数から配列の大きさ設定
　　dX = CLng(dDate - STARTDAY) + 1
　　ReDim v(1 To dX + 1, 1 To CX)
　　w = Split(FLD)

　　'コード範囲Loop
　　For Each r In rng
　　　　cd = CStr(r.Value)
　　　　If IsNumeric(cd) Then
　　　　　　flg = False
　　　　　　On Error Resume Next
　　　　　　Set ws = Sheets(cd)
　　　　　　On Error GoTo errHndlr
　　　　　　'新規コード時Sheet追加
　　　　　　If ws Is Nothing Then
　　　　　　　　flg = True
　　　　　　　　Set ws = Sheets.Add
　　　　　　　　ws.Name = cd
　　　　　　　　ws.Columns(2).NumberFormat = "yyyy/mm/dd"
　　　　　　　　ws.Range("B1").Resize(, CX).Value = w
　　　　　　　　dCHK = STARTDAY
　　　　　　Else
　　　　　　　　dCHK = Application.Max(ws.Columns(2)) + 1
　　　　　　　　If dCHK < STARTDAY Then dCHK = STARTDAY
　　　　　　End If
　　　　　　'期間日数分Loop（50行/ページ）
　　　　　　st(0) = "http://table.yahoo.co.jp/t?s=" & cd
　　　　　　url = Join(st, "&")
　　　　　　cnt = 1
　　　　　　For i = 0 To dX Step 50
　　　　　　　　xml.Open "GET", url & i, False
　　　　　　　　xml.Send
　　　　　　　　If (xml.Status < 200) Or (xml.Status >= 300) Then Exit For
　　　　　　　　'ページソース文字列GET
　　　　　　　　ret = xml.responsetext
　　　　　　　　'テーブル位置チェック
　　　　　　　　po(0) = InStr(ret, CK0)
　　　　　　　　If po(0) = 0 Then Exit For
　　　　　　　　'銘柄名取得
　　　　　　　　If flg Then
　　　　　　　　　　po(1) = InStr(ret, CK1)
　　　　　　　　　　po(2) = InStr(ret, CK2)
　　　　　　　　　　If (po(1) > 0) And (po(2) > 0) Then
　　　　　　　　　　　　po(1) = po(1) + Len(CK1)
　　　　　　　　　　　　ws.Range("A1").Value = Mid$(ret, po(1), po(2) - po(1))
　　　　　　　　　　　　flg = False
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　　　'文字列再セット
　　　　　　　　ret = Mid$(ret, po(0) + Len(CK0))
　　　　　　　　'>と<で囲まれた文字列にMatch
　　　　　　　　Set mc = reg.Execute(ret)
　　　　　　　　'配列Loop
　　　　　　　　x = 0
　　　　　　　　For j = 1 + i To 50 + i
　　　　　　　　　　cnt = j
　　　　　　　　　　v(j, 1) = mc(x).SubMatches(0)
　　　　　　　　　　'1列目でデータ終了判定
　　　　　　　　　　If IsDate(v(j, 1)) Then
　　　　　　　　　　　　v(j, 1) = CDate(v(j, 1))
　　　　　　　　　　　　flg = (v(j, 1) < dCHK)
　　　　　　　　　　End If
　　　　　　　　　　If flg Then
　　　　　　　　　　　　i = dX
　　　　　　　　　　　　cnt = cnt - 1
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　　　x = x + 1
　　　　　　　　　　For k = 2 To CX
　　　　　　　　　　　　v(j, k) = mc(x).SubMatches(0)
　　　　　　　　　　　　x = x + 1
　　　　　　　　　　Next
　　　　　　　　Next
　　　　　　Next
　　　　　　If cnt > 0 Then
　　　　　　　　With ws
　　　　　　　　　　'データ書き出しと降順Sort
　　　　　　　　　　n = .Cells(.Rows.Count, 2).End(xlUp).Row
　　　　　　　　　　.Cells(n + 1, 2).Resize(cnt, CX).Value = v
　　　　　　　　　　.Range("B1:H1").Resize(n + cnt). _
　　　　　　　　　　　　　　Sort Key1:=.Range("B2"), _
　　　　　　　　　　　　　　　　 Order1:=xlDescending, _
　　　　　　　　　　　　　　　　 Header:=xlYes, _
　　　　　　　　　　　　　　　　 OrderCustom:=1, _
　　　　　　　　　　　　　　　　 MatchCase:=True, _
　　　　　　　　　　　　　　　　 Orientation:=xlSortColumns, _
　　　　　　　　　　　　　　　　 SortMethod:=xlStroke
　　　　　　　　End With
　　　　　　End If
　　　　End If
　　　　Set ws = Nothing
　　Next

errHndlr:
　　Set mc = Nothing
　　Set reg = Nothing
　　Set xml = Nothing
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　MsgBox .Number & vbLf & .Description
　　　　End If
　　End With
End Sub