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 メモ
物忘れ防止 Yahoo!運賃検索.xlsm