正規表現でデーター取得

質問

Webクエリで株価取得しようマクロを作ったのですが
IE7を使用しているので、出来ないことが分かり
正規表現にて取得しようとしてみましたが
うまく取得できません。

http://www.technobahn.com/apps/fn/quote?r=3m&c=1412&s=medium&color=&lang=

上記リンク先の始値～相場全体までのデータを
取得したいのですが・・・

とりあえずは、取得したデータをsheet2．A列に入れてみたのですが
文字化けに関係のないデータまでもを取得しています。

sheet1
　A　　 　
コード

Const vaa As String = "Ver1.02"

Const URLI As String = "http://www.technobahn.com/apps/fn/quote?r=3m&c="
Dim urlweb As String 'Web接続先
Dim code As String '銘柄コード

Sub 株価取得()

Dim oHttp As Object, ws1 As Object, ws2 As Object
Dim dthtml As String
Dim chktb As String
Dim stchk1 As Long
Dim stchk2 As Long
Dim chksu As Long
Dim j As Integer
Dim urlweb As String
Dim mino As Long, w As Long

Set ws1 = Sheets(1)
Set ws2 = Sheets(2)

w = 1

mino = ws1.Cells(w, 1)

urlweb = URLI & "mino"

Set oHttp = CreateObject("Microsoft.XMLHTTP")
oHttp.Open "GET", urlweb, False
oHttp.Send
dthtml = oHttp.responsetext

With CreateObject("VBScript.RegExp")
.Pattern = ">([^<>]+)<"
.Global = True
On Error Resume Next
stchk1 = InStr(dthtml, "始値")
stchk2 = InStrRev(Left(dthtml, stchk1), "table")
chksu = InStr(stchk2, dthtml, "</table")
dthtml = Mid$(dthtml, stchk2, chksu)

itmsu = .Execute(dthtml).Count
ReDim hdat(itmsu)

With .Execute(dthtml)
For j = 1 To itmsu
ws2.Cells(j, 1) = .Item(j).SubMatches(0)
Next j
End With
On Error GoTo 0
End With
Set oHttp = Nothing
DoEvents

End Sub

回答No.6

end-u · ベストアンサー

>出来高がない銘柄に関してはずれが発生しています。
閉じてない<td>タグがあったり、ちょっと面倒そうですね。
一括でできそうにも思えるのですが、正規表現もあまり得意ではないので
取り敢えず　"(?!<td)<[^>]+>|&nbsp;"　これでtdタグ以外を消して分割し、揃えてみたらどうでしょう。

Option Explicit

Sub try()
　　Const URL = "http://www.technobahn.com/apps/fn/quote?r=3m&lang=jp&c="
　　Const chkS = "<table border=0 cellpadding=0 cellspacing=0 width=""100%"">" _
　　　　　　　 & "<tr bgcolor=""#F0F0F0"">"
　　Const chkE = "<SCRIPT LANGUAGE=""JavaScript"">"
　　Const adTypeBinary As Long = 1
　　Const adTypeText As Long = 2
　　Dim xhtp　As Object
　　Dim strm　As Object
　　Dim reg　 As Object
　　Dim shtm　As String
　　Dim tmp　 As String
　　Dim ret() As String
　　Dim cnt　 As Long
　　Dim p1　　As Long
　　Dim p2　　As Long
　　Dim mx　　As Long
　　Dim x　　 As Long
　　Dim j　　 As Long
　　Dim code, v
　　'Dim t As Single

　　't = Timer
　　code = [{"1634","1635"}]
　　'With Sheets("sheet1")
　　'　　code = .Range(.Cells(1), .Cells(.Rows.Count, 1).End(xlUp)).Value
　　'End With
　　ReDim ret(1 To UBound(code), 0 To 255)
　　Set xhtp = CreateObject("Microsoft.XMLHTTP")
　　Set strm = CreateObject("ADODB.Stream")
　　Set reg = CreateObject("VBScript.RegExp")

　　strm.Open
　　reg.Global = True
　　reg.IgnoreCase = True
　　For Each v In code
　　　　xhtp.Open "GET", URL & v, False
　　　　xhtp.Send
　　　　If (xhtp.Status >= 200) And (xhtp.Status < 300) Then
　　　　　　With strm
　　　　　　　　.Position = 0
　　　　　　　　.Type = adTypeBinary
　　　　　　　　.Write xhtp.responsebody
　　　　　　　　.Position = 0
　　　　　　　　.Type = adTypeText
　　　　　　　　.Charset = "euc-jp"
　　　　　　　　tmp = .ReadText()
　　　　　　End With
　　　　　　p1 = InStr(tmp, chkS)
　　　　　　If p1 > 0 Then
　　　　　　　　p2 = InStr(p1, tmp, chkE)
　　　　　　　　If p2 = 0 Then
　　　　　　　　　　p2 = Len(tmp)
　　　　　　　　End If
　　　　　　　　cnt = cnt + 1
　　　　　　　　tmp = Mid$(tmp, p1, p2 - p1)
　　　　　　　　With reg
　　　　　　　　　　'『tdタグ以外』or『&nbsp;』を削除
　　　　　　　　　　.Pattern = "(?!<td)<[^>]+>|&nbsp;"
　　　　　　　　　　tmp = .Replace(tmp, "")
　　　　　　　　　　.Pattern = ">([^<>]*)<"
　　　　　　　　　　With .Execute(tmp)
　　　　　　　　　　　　x = .Count
　　　　　　　　　　　　If mx < x Then
　　　　　　　　　　　　　　'If x > 255 Then x = 255
　　　　　　　　　　　　　　mx = x
　　　　　　　　　　　　End If
　　　　　　　　　　　　'取り敢えず全フィールド取得してみる
　　　　　　　　　　　　For j = 0 To x - 1
　　　　　　　　　　　　　　ret(cnt, j) = .Item(j).SubMatches(0)
　　　　　　　　　　　　Next
　　　　　　　　　　End With
　　　　　　　　End With
　　　　　　End If
　　　　End If
　　Next
　　strm.Close

　　If cnt > 0 Then
　　　　Sheets.Add.Cells(1).Resize(cnt, mx).Value = ret
　　End If

　　Set reg = Nothing
　　Set xhtp = Nothing
　　Set strm = Nothing
　　'Debug.Print Timer - t
End Sub
#これでも『テクニカル指標』以降のフィールドはズれてしまうようですが。

お礼

どうもありがとうございます。
上記のコードで試し"1634","1635"の
取得ページを確認したところ
ずれの原因は、
1634
<td></td><td colspan="2"></td>
1635
<td><font...>変動率2.66%</font><font...> (ローリスク)</font></td>
ここですね。
値が入力さてない1634は<TD>ダグが二つ。
値が入力されている1635は<TD>ダグが一つでした。

>出来高がない銘柄に関してはずれが発生しています。
この時のずれの原因はデータなし（『&nbsp;』もなし）の
<td></td>ダグを取得できてなく
ずれが発生していたんじゃないかと思ったのですが。

教えていただいたVBコードでは、
データなし（『&nbsp;』）の<td></td>ダグも
取得できていました。

googleプラウザの要素検証で
ずれの場所のタグを確認してみました。

補足

遅くなりましたが
テクニカルまではちゃんとずれなく
取得できました。

http://www.geocities.jp/gimonyou01/ws07.jpg

いろいろありがとうございました。

回答No.5

end-u

>正規表現をいろいろ試してみたところ
>
>([^#&#nbsp;]+)を足すことで#&#nbsp;は
>
>取得せずにすんだのですが....
>
>.Pattern = ">([^#&#nbsp;]+)([^<>]+)<"

そのPatternではうまくいかない気が？
素直にReplaceしちゃえば良いと思いますけど。

stchk1 = InStr(dthtml, ">Open")
If stchk1 > 0 Then
　　'stchk2 = InStrRev(Left(dthtml, stchk1), "table")
　　chksu = InStr(stchk1, dthtml, "</table")
　　dthtml = Mid$(dthtml, stchk1, chksu - stchk1)
　　With CreateObject("VBScript.RegExp")
　　　　.Global = True
　　　　.Pattern = "&nbsp;"
　　　　dthtml = .Replace(dthtml, "")
　　　　.Pattern = ">([^<>]+)<"
　　　　itmsu = .Execute(dthtml).Count
　　　　ReDim hdat(itmsu)
　　　　With .Execute(dthtml)
　　　　　　For j = 0 To itmsu - 1
　　　　　　　　hdat(j) = .Item(j).SubMatches(0)
　　　　　　Next
　　　　End With
　　End With
　　ws2.Cells(1).Resize(itmsu).Value = Application.Transpose(hdat)
End If
#取得ページをlang=jpからlang=enに変更したのかな？

余談ですが、tableの形で取得したい場合、複数コード分をまとめて文字列で取得した後、
"</tr>"→vbLf
"</td>"→vbTab
"<([^>]+)>|&nbsp;"→""
それぞれReplaceして
：
'参照設定:Microsoft Forms 2.0 Object Library
With New DataObject
　　.Clear
　　.SetText dthtml
　　.PutInClipboard
End With
ws2.Paste ws2.Cells(1)
：
っみたいにしたほうが比較的簡単なんじゃないかなあ...などと。#素人考えですが。

お礼

どうもありがとうございました。
.Pattern = " "
　　　　dthtml = .Replace(dthtml, "")
　　　　.Pattern = ">([^<>]+)<"
に変更したところちゃんと取得できました。
まだ、コードの整理はしてないですが

w = ws1.Range("A" & Rows.Count).End(xlUp).Row - 1
For i = 1 To w
mino = ws1.Cells(i + 1, 1)
urlweb = URLI & mino
Set oHttp = CreateObject("Microsoft.XMLHTTP")
oHttp.Open "GET", urlweb, False
oHttp.Send

Dim objStm As Object
Set objStm = CreateObject("ADODB.Stream")
objStm.Open
objStm.Type = adTypeBinary
objStm.Write oHttp.responsebody

objStm.Position = 0
objStm.Type = adTypeText
objStm.Charset = "EUC-JP"
dthtml = objStm.readtext()

objStm.Close
Set objStm = Nothing

With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = " "
dthtml = .Replace(dthtml, "")
.Pattern = ">([^<>]+)<"

itmsu = .Execute(dthtml).Count
ReDim hdat(itmsu)
With .Execute(dthtml)
For j = 0 To itmsu - 1
hdat(j) = .Item(j).SubMatches(0)
Next j
'取得データ貼り付け
ws1.Cells(i + 1, 4) = hdat(191)
　　　　　　　～～省略～～　
ws1.Cells(i + 1, 34) = hdat(227)

End With
On Error GoTo 0
End With
Set oHttp = Nothing
DoEvents
Next i
End Sub

hdat(＃)の番号を指定した事で
出来高がある銘柄はちゃんと取得できているのですが
出来高がない銘柄に関してはずれが発生しています。
約900銘柄抽出で2分ぐらいでした。
楽天ＲＳＳより早いですね。

ご指摘を受けたところは調べて理解したいと思います。

回答No.4

ki-aaa

今日を

次の部分を入れ替えて実行してみてください。
それから、私、正規表現は　">([^<>]+)<"　しか使ったことがありませんので、あしからず。

With CreateObject("VBScript.RegExp")
' .Pattern = ">([^<>]+)<"
.Pattern = ">([^#&#nbsp;]+)([^<>]+)<"
.Global = True
' stchk1 = InStr(dthtml, "始値")
' If stchk1 = 0 Then
' stchk1 = InStr(dthtml, "Open")
' End If
' stchk2 = InStrRev(Left(dthtml, stchk1), "table")
' chksu = InStr(stchk2, dthtml, "</table")
' dthtml = Mid$(dthtml, stchk2, chksu - stchk2)
itmsu = .Execute(dthtml).Count
ws2.Columns("A:D").Clear
With .Execute(dthtml)
For j = 0 To itmsu - 1
ws2.Cells(j + 1, 1) = .Item(j).SubMatches(0) & .Item(j).SubMatches(1)
ws2.Cells(j + 1, 2) = j
ws2.Cells(j + 1, 3) = .Item(j).SubMatches(0)
ws2.Cells(j + 1, 4) = .Item(j).SubMatches(1)
Next j
End With
End With

Set oHttp = Nothing
DoEvents

End Sub

それから、四本値だけでいいんでしたら、end-uさんが完璧な回答をなさっていますので検索してください。

お礼

どうもありがとうございました。
.Pattern = を追加してやってみましたが
駄目でした。
四本値だけなら、楽天RSSでできるんですが
リンク先の移動平均など
取得したいと思っています。
他のサイトで時系列を抜いて
エクセルシートでの計算でもいいのですが
このサイトだとほぼ掲載されているので。

回答No.3

ki-aaa

今日わ

回答番号：No.2のエラーの原因
>urlweb = URLI & "mino"
urlweb = URLI & mino

後、気になるところを書きます。
>stchk1 = InStr(dthtml, "始値")
このあと、stchk1がゼロだった("始値"が無かった)ときの処理を書きます。

>For j = 1 To itmsu
>ws2.Cells(j, 1) = .Item(j).SubMatches(0)　は
For j = 0 To itmsu - 1
ws2.Cells(j + 1, 1) = .Item(j).SubMatches(0)

普通、指定の無い配列は、0から始まります。

>dthtml = Mid$(dthtml, stchk2, chksu)
この式のchksuは長さを指定します。今は、ポジションになっています。

でわ、頑張ってください。

お礼

どうもありがとうございました。
ご指摘の部分は修正し動くようになりました。

>dthtml = Mid$(dthtml, stchk2, chksu)
　この部分はまだですが・・色々検索して調べています。

データを取得できたのはいいのですが

http://www.technobahn.com/apps/fn/quote?r=3m&c=1412
例：リンク先、50D MA　#&#nbsp;-11.42%#&#nbsp;　'#は関係ないです

とソースで表示されてる部分がうまく取得できません。

#&#nbsp;取り除こうとすると、その他数字データが

実数型で取得されてしまいす。

例：Previous close　#17,570#　取得後　#17.57#

と、表示されてしまいます。

正規表現をいろいろ試してみたところ

([^#&#nbsp;]+)を足すことで#&#nbsp;は

取得せずにすんだのですが....

With CreateObject("VBScript.RegExp")
.Pattern = ">([^#&#nbsp;]+)([^<>]+)<"
.Global = True
On Error Resume Next
stchk1 = InStr(dthtml, "Open")
stchk2 = InStrRev(Left(dthtml, stchk1), "table")
chksu = InStr(stchk2, dthtml, "</table")
dthtml = Mid$(dthtml, stchk2, chksu)

itmsu = .Execute(dthtml).Count
ReDim hdat(itmsu)
With .Execute(dthtml)
For j = 0 To itmsu - 1
hdat(j) = .Item(j).SubMatches(0)

Next j
Dim i As Long　
For i = 1 To 25　'25という数字はとりあえずです。
ws1.Cells(2, i + 3) = hdat(i)
Next i
End With
On Error GoTo 0
End With
Set oHttp = Nothing
DoEvents

WEBクエリで取得したときと
正規表現で取得したときの
処理速度が全然違いますね。
びっくりするくらい早いですね。

回答No.2

AKARI0418

面白そうですねがんばってください！！

Sub 株価取得()

Dim oHttp As Object, ws1 As Object, ws2 As Object
Dim dthtml As String
Dim chktb As String
Dim stchk1 As Long
Dim stchk2 As Long
Dim chksu As Long
Dim j As Integer
Dim urlweb As String
Dim mino As Long, w As Long

'追加
Const adTypeBinary As Long = 1
Const adTypeText As Long = 2

Set ws1 = Sheets(1)
Set ws2 = Sheets(2)

w = 1

mino = ws1.Cells(w, 1)

urlweb = URLI & "mino"

Set oHttp = CreateObject("Microsoft.XMLHTTP")
oHttp.Open "GET", urlweb, False
oHttp.Send

Dim objStm As Object
Set objStm = CreateObject("ADODB.Stream")
objStm.Open
objStm.Type = adTypeBinary
objStm.Write oHttp.responsebody

objStm.Position = 0
objStm.Type = adTypeText
objStm.Charset = "euc-jp"
dthtml = objStm.ReadText()

objStm.Close
Set objStm = Nothing

With CreateObject("VBScript.RegExp")
.Pattern = ">([^<>]+)<"
.Global = True
On Error Resume Next
stchk1 = InStr(dthtml, "始値")
stchk2 = InStrRev(Left(dthtml, stchk1), "table")
chksu = InStr(stchk2, dthtml, "</table")
dthtml = Mid$(dthtml, stchk2, chksu)

itmsu = .Execute(dthtml).Count
ReDim hdat(itmsu)
With .Execute(dthtml)
For j = 1 To itmsu
ws2.Cells(j, 1) = .Item(j).SubMatches(0)
Next j
End With
On Error GoTo 0
End With
Set oHttp = Nothing
DoEvents

End Sub

補足

どうもありがとうございます。
このサイトでデータを抜けたら不要な作業がなくなるの
頑張っています。
objStm.Write oHttp.responsebody
ここで3001エラーが発生するのですが
なぜエラーが発生しているのか理解できません。
よろしければ教えてもらえないでしょうか？

回答No.1

end-u

正規表現の問題ではなく、『CHARSET=EUC-JP』のようですからADODB.Streamで変換したりする必要があるのでは。
まずは、こんなのでちょっと試してみると良いかも。
Sub test()
　　'本掲示板の仕様対策の為『&』で繋いでるだけなので通常は&不要
　　Const URLI = "h" & "ttp://w" & _
　　　　　　　　 "ww.technobahn.com/apps/fn/quote?r=3m&lang=jp&c="
　　Const outfiL1 = "c:\temp\temp1.txt"
　　Const outfiL2 = "c:\temp\temp2.txt"
　　Const adTypeBinary As Long = 1
　　Const adTypeText　 As Long = 2
　　Dim oHttp As Object
　　Dim dtHtm As String
　　Dim fiLeN As Long

　　Set oHttp = CreateObject("Microsoft.XMLHTTP")
　　oHttp.Open "GET", URLI & "1412", False
　　oHttp.Send
　　dtHtm = oHttp.responsetext

　　fiLeN = FreeFile
　　Open outfiL1 For Output As #fiLeN
　　Print #fiLeN, dtHtm
　　Close #fiLeN

　　With CreateObject("ADODB.Stream")
　　　　.Open
　　　　.Type = adTypeBinary
　　　　.Write oHttp.responsebody
　　　　.Position = 0
　　　　.Type = adTypeText
　　　　.Charset = "euc-jp"
　　　　dtHtm = .readtext
　　　　.Close
　　End With

　　fiLeN = FreeFile
　　Open outfiL2 For Output As #fiLeN
　　Print #fiLeN, dtHtm
　　Close #fiLeN

　　Set oHttp = Nothing
End Sub

お礼

どうもありがとございました。
temp2.txtにて、変換されたデータを確認できました。
これをエクセルに取り込んでみたいと思います。