[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『WEBページよりVBAで値を取得したい』（jnk）
WEBページ：https://www.sapientica.com/success/
上記のサイトから、開成中学校 麻布中学校 武蔵中学校 桜蔭中学校 女子学院の合格者数を抽出したいです。
以下のコードで実行しても数値が0でしか返されません。
VBA初心者であり、知識不足だと思います。
どなたかご協力お願いします。
Sub Getサピ御三家()
Dim html As String, msg As String
Dim 中学() As String, l As Long, i As Long
Dim http As Object
中学 = Split("開成中学校 麻布中学校 武蔵中学校 桜蔭中学校 女子学院中学校 雙葉中学校")
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://www.sapientica.com/success/"
http.send
Do While http.readyState < 4
DoEvents
Loop
html = http.responseText
For i = LBound(中学) To UBound(中学)
l = InStr(html, ">" & 中学(i) & "<")
l = InStr(l, html, "<span class = badge>") + 3
msg = msg & 中学(i) & ":" & vbTab & Val(Mid(html, l, 4)) & vbLf
Next
Set http = Nothing
MsgBox msg
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
こうじゃないのかな。
Sub Getサピ御三家()
Const myStr As String = "<span class=""badge"">"
Dim html As String, msg As String
Dim 中学() As String, l As Long, i As Long, l2 As Long
Dim http As Object
中学 = Split("開成中学校 麻布中学校 武蔵中学校 桜蔭中学校 女子学院中学校 雙葉中学校")
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://www.sapientica.com/success/", False 'Falseで同期処理となる
http.send
html = http.responseText
For i = LBound(中学) To UBound(中学)
l = InStr(html, ">" & 中学(i) & "<")
l2 = InStr(l + 1, html, myStr) + Len(myStr)
msg = msg & 中学(i) & ":" & vbTab & Val(Mid(html, l2, 4)) & vbLf
Next
Set http = Nothing
Debug.Print msg 'イミディエイトウインドウに出力
End Sub
（γ） 2022/02/15(火) 12:25
流れ理解確認
・中学という変数に調べたい文字列を配列として格納
・http変数にウェブページの情報を格納
・ウェプページ内で配列内の文字列開始位置を調べる
この後のコードが理解できていません、、、
l2 = InStr(l + 1, html, myStr) + Len(myStr)
上記の説明＆流れに関してどなたか再度ご教授お願い致します。
（jnk） 2022/02/16(水) 15:56
（γ） 2022/02/16(水) 16:22
l2 = InStr(l + 1, html, myStr) + Len(myStr)
こちらのコードって+ Len(myStr)で数値の値取得しているのでしょうか？
すいません何度も質問、理解力なく、、
（jnk） 2022/02/16(水) 16:51
では少し補足説明します。
<dt class="list-sname">開成中学校</dt>
<dd class="list-sgoukaku"><span class="badge">282</span></dd>
というようなHTMLソースがありますね。
・最初に">開成中学校<"にマッチする位置を調べ
・その次に、その位置(+1は不要だった）を検索の開始位置とし、
myStr(つまり、<span class="badge">)を検索します。
・l2 = InStr(l + 1, html, myStr) + Len(myStr)の
InStr(l + 1, html, myStr)は、
<span class="badge">の最初の文字の位置を示します。
↑ ここです。
（なお、検索スタート点からのカウントではなく、文字列の最初からの位置であることに注意。）
これにLen(myStr)を加えると、
<span class="badge">282 の2の位置を指します。
↑ここです
・Val(Mid(html, l2, 4))によって、
282< を数値化して 282を得ます。
最初のコードでまずいのは、 検索文字列が <span class = badge> とスペースや"の有無が適切ではなかったこと。
------ なお、 http.Openの第三引数は、非同期設定ですので、これを Falseにすると 同期処理（つまり、send実行の結果が返って来るまで、処理を待ち、 次のコード実行には進まない)となり、処理待ちのコードは不要ということになります。 （γ） 2022/02/16(水) 17:15
（jnk） 2022/02/16(水) 18:40
γのフォントが違うだけです。 （γ） 2022/02/16(水) 19:02
https://www.ichishin.co.jp/lp/pass-record/es/sokuhou.html
Sub Get市進()
Const myStr As String = "<span class= ""red-l3"" >"
Dim html As String, msg As String
Dim 中学() As String, l As Long, i As Long, l2 As Long
Dim http As Object
中学 = Split("市川中 栄東中 開智中 渋谷幕張中")
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://www.ichishin.co.jp/lp/pass-record/es/sokuhou.html", False 'Falseで同期処理となる
http.send
html = http.responseText
For i = LBound(中学) To UBound(中学)
l = InStr(html, ">" & 中学(i) & "<")
l2 = InStr(l, html, myStr) + Len(myStr)
msg = msg & 中学(i) & ":" & vbTab & Val(Mid(html, l2, 4)) & vbLf
Next
Set http = Nothing
MsgBox msg
End Sub
（jnk） 2022/02/18(金) 12:18
（γ） 2022/02/18(金) 13:05
responseTextには返さず、responseBodyにのみ返す仕組みをとっているようです。 以下のようにしてください。 # 昔書いたコードから一部をとってきているので、今どきはもっと気の利いたものがあるのかもしれません。
Sub Get市進()
Const myStr As String = "<span class=""red-l3"">" '■修正しています
Dim html As String, msg As String
Dim 中学() As String, l As Long, i As Long, l2 As Long
Dim http As Object
中学 = Split("市川中 栄東中 開智中 渋谷幕張中")
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://www.ichishin.co.jp/lp/pass-record/es/sokuhou.html", False 'Falseで同期処理となる
http.send
html = getHtml(http)
For i = LBound(中学) To UBound(中学)
l = InStr(html, ">" & 中学(i) & "<")
l2 = InStr(l, html, myStr) + Len(myStr)
msg = msg & 中学(i) & ":" & vbTab & Val(Mid(html, l2, 4)) & vbLf
Next
Set http = Nothing
Debug.Print msg
End Sub
Function getHtml(HttpRequest As Object) As String
Const adTypeBinary = 1
Const adTypeText = 2
Const adSaveCreateOverWrite = 2
Dim Strm As Object
Set Strm = CreateObject("ADODB.Stream")
With Strm
.Open
.Type = adTypeBinary
.Write HttpRequest.responseBody
.Position = 0
.Type = adTypeText
.Charset = "UTF-8"
getHtml = .ReadText()
.Close
End With
End Function
ちなみに、
Const myStr As String = "<span class= ""red-l3"" >"
としていますが、余計な空白が混じっています。よく確認してください。
これは、人間がノートに手書きする文字なら、他の人は忖度して理解してくれますが、
機械はそうした機転は利きません。別の文字列と認識されます。
前回にも指摘しているはずですが？ 適当に聞き流しています？
なお、こうしたことを本格的にするのであれば、外注したほうが早いし、 アフターサービスも期待できるでしょう。コストは少しかかりますが。
# 外出しますので、しばらくアクセスできません。
（γ） 2022/02/18(金) 14:16
頂いたコード勉強します。
今回のはかなり難しそうですが、、
(Y)様のおかげで今回のようなサイト以外に関しては値とれるのでかなり業務効率改善しました
ありがとうございます。
（jnk） 2022/02/18(金) 16:07
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.