VBAでHTMLを取得
関連
HTTPリクエストを投げて、レスポンスを受け取る vbscript
Excel 郵便番号→住所変換 MSXML2.XML HTTP.3.0
HTTPリクエストの検索でHitしたAccessのVBAでYahoo!路線情報からHTMLを取得して運賃を取得してみるは、Accessだったので、Excel化してみた。
MSXML2.XMLHTTP.3.0
Option Explicit
'******************************************
'Yahoo!運賃検索
'https://transit.yahoo.co.jp/search/result?flatlon=&fromgid=&from=東京&to=名古屋
'******************************************
Public Sub cmd_Click()
Dim s出発 As String
Dim s到着 As String
Dim w_URL As String
Dim objHttp As Object
Dim strHtml As Variant
Dim wstrHtml As Variant
Dim i As Integer
Dim matchArray As Variant
Dim subMatchArray As Variant
Dim rc
With ThisWorkbook.Sheets("Sheet1")
.Range("C5:F8").ClearContents
s出発 = .Range("C2")
s到着 = .Range("C3")
If s出発 = "" Or s到着 = "" Then Exit Sub '入力漏れがある場合は処理しない。
'文字コードをUTF-8に変換
s出発 = Application.WorksheetFunction.EncodeURL(s出発)
s到着 = Application.WorksheetFunction.EncodeURL(s到着)
'Yahoo!運賃検索URLを作成する
'https://transit.yahoo.co.jp/search/result?flatlon=&fromgid=&from=大阪&to=京都&shin=1&ex=1&hb=1&al=1&lb=1&sr=1&type=1&ws=3&s=0
w_URL = "https://transit.yahoo.co.jp/search/result?flatlon=&fromgid=&from=" & s出発 & "&to=" & s到着 & "&shin=1&ex=1&hb=1&al=1&lb=1&sr=1&type=1&ws=3&s=0"
Set objHttp = CreateObject("MSXML2.XMLHTTP.3.0") 'XMLHTTPオブジェクトを作成します
objHttp.Open "GET", w_URL, False 'HTTPリクエストを作成する false:同期処理
objHttp.Send 'HTTPリクエストをサーバに送信する
strHtml = objHttp.responseText 'HTMLソースを取得する
strHtml = Replace(strHtml, Chr(34), "", 1, -1, vbBinaryCompare) '正規表現を簡単にするためにダブルクオーテーションを除去
strHtml = Replace(strHtml, vbLf, "", 1, -1, vbBinaryCompare) '正規表現を簡単にするために改行(\n)を除去
'区間を取得する
rc = RegExpMatch(strHtml, "<h1 class=title>(.*?)</h1>", matchArray, False, True)
If rc Then
.Range("C5").Value = RegExpReplace(matchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True) 'タグの除去 区間
End If
'区間を取得する
rc = RegExpMatch(strHtml, "<a href=#route0(.*?)</ul>", matchArray, False, True)
If rc Then
For i = 0 To 2
wstrHtml = matchArray(1, UBound(matchArray, 2))
'ルートx
rc = RegExpMatch(matchArray(1, i), "</span>(.*?)</a>", subMatchArray, False, True)
If rc Then
.Range("C6").Offset(i, 0).Value = RegExpReplace(subMatchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True) 'タグの除去 区間
End If
'10:10 → 12:10
rc = RegExpMatch(matchArray(1, i), "<li class=time>(.*?)<span class=small>", subMatchArray, False, True)
If rc Then
.Range("C6").Offset(i, 1).Value = RegExpReplace(subMatchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True) 'タグの除去 区間
End If
'時間
rc = RegExpMatch(matchArray(1, i), "<span class=small>(.*?)</span>", subMatchArray, False, True)
If rc Then
.Range("C6").Offset(i, 2).Value = RegExpReplace(subMatchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True) 'タグの除去 区間
End If
'料金
rc = RegExpMatch(matchArray(1, i), "<li class=fare>(.*?)</li>", subMatchArray, False, True)
If rc Then
.Range("C6").Offset(i, 3).Value = RegExpReplace(subMatchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True) 'タグの除去 区間
End If
Next
End If
End With
End Sub
'-------------------------------------------
' マッチ
' [string_]内に[patrn_]と一致するものを検索する、その結果と、一致するものの文字位置と文字を返す
'-------------------------------------------
' 引数
' string_ : 検索対象文字列
' patrn_ : 検索パターン
' AnsArray_ :
' IgnoreCase_ : 大文字と小文字を区別指定
' true : 大文字と小文字を区別します
' false : 大文字と小文字を区別しない
' Global_ : 検索範囲指定
' true : 文字列全体を検索する
' false : 最初の一致まで検索する
'
' 戻り値
' RegExpMatch : false 検索結果で一致するものが存在しない
' : true 検索結果で一致するものが存在する
' AnsArray(x,y) 一致するものの文字位置と文字
' AnsArray(0,y) 一致するものの文字位置
' AnsArray(1,y) 一致する文字
'-------------------------------------------
Private Function RegExpMatch(string_, patrn_, AnsArray_, IgnoreCase_, Global_)
Dim regEx: Set regEx = CreateObject("VBScript.RegExp") ' 正規表現を作成します。
Dim Match ' 一致文字位置と文字コレクションを受け取るWK
Dim Matches ' 検索実行結果を受け取る
Dim fAnsArray(): ReDim fAnsArray(1, 0) ' 一致するものの文字位置と文字配列
regEx.Pattern = patrn_ ' パターンを設定します。
regEx.IgnoreCase = IgnoreCase_ ' 大文字と小文字を区別
regEx.Global = Global_ ' 検索範囲指定
Set Matches = regEx.Execute(string_) ' 検索を実行します。(検索結果で一致するものがなくても配列が返る)
RegExpMatch = False ' 検索結果で一致するものが存在しないにする
For Each Match In Matches ' Matches コレクションに対して繰り返し処理を行います。
If RegExpMatch Then
ReDim Preserve fAnsArray(1, UBound(fAnsArray, 2) + 1) ' AnsArrayの拡張
End If
RegExpMatch = True ' 検索結果で一致するものが存在する
fAnsArray(0, UBound(fAnsArray, 2)) = Match.FirstIndex ' 一致する文字列が見つかった位置
fAnsArray(1, UBound(fAnsArray, 2)) = Match.Value ' 一致した文字列
Next
AnsArray_ = fAnsArray
Set regEx = Nothing ' 正規表現を作成します
Set Match = Nothing ' 一致文字位置と文字コレクションを受け取るWK
Set Matches = Nothing ' 検索実行結果を受け取る
Erase fAnsArray
End Function
'-------------------------------------------
' 置換
' [string_]内に[patrn_]と一致するものを[replStr_]へ置換を行った結果を返す
'-------------------------------------------
' 引数
' string_ : 検査対象文字列
' replStr_ : 置換え文字列
' patrn_ : 検査パターン
' IgnoreCase_ : 大文字と小文字を区別指定
' true : 大文字と小文字を区別します
' false : 大文字と小文字を区別しない
' Global_ : 検索範囲指定
' true : 文字列全体を検索する
' false : 最初の一致まで検索する
' 戻り値
' RegExpReplace : 置換を行った結果
'-------------------------------------------
Private Function RegExpReplace(string_, replStr_, patrn_, IgnoreCase_, Global_)
If IsNull(string_) Or string_ = "" Then
RegExpReplace = ""
Exit Function
End If
Dim regEx: Set regEx = CreateObject("VBScript.RegExp") ' 正規表現を作成します。
regEx.Pattern = patrn_ ' パターンを設定します。
regEx.IgnoreCase = IgnoreCase_ ' 大文字と小文字を区別
regEx.Global = Global_ ' 検索範囲指定
RegExpReplace = regEx.Replace(string_, replStr_) ' 置換します。
Set regEx = Nothing
End Function
関連
EncodeURL メモ