Excel VBAを使用してIEを呼び出し、Webページを操作する

多くの場合、Excelにコンテンツを読み取る必要があるため、VBAを使用してこの機能を実現できます。
ExcelとVBAの知識が限られており、発生した問題の一部しか解決できず、すべての場合に適しているとは限りません。 次のコンテンツは、基本的なVBAの使い方とHTML言語の知識の理解に基づいています。

事前準備

著者の知る限り、VBAはブラウザやWebページを操作できません。やれることは、IEでいくつかの操作を実行することだけです。そうです、IEだけです。コンピューターにIEがない場合、Subを終了して、次の操作は進めません。Pythonがimportを使用し、C#がusingを使用することと同じように、VBAもIEを操作するためにいくつかのライブラリを参照する必要があります。幸い、これはMicrosoft製品であるため、VBAに付属するいくつかのライブラリを簡単に使用できます。

Webページの操作

Micorsoft Internet Controlsを参照した後、そのページに対してやりたい放題できますが、ホームページにWebページが必要です。

Webページを開きます

例として、Googleで“tokyo”キーワードを検索します。

 With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate "https://www.google.com/search?q=tokyo"
'Webページを閉じる
'       .Quit
    End With

コードは非常に簡単で、最初にIEオブジェクトを作成してから、いくつかのプロパティに値を割り当てます。 Visibleは可視性で、Webページが操作されたときにWebページが表示されるかどうかを示します。習熟したら、Falseに設定できます。これより、プログラムの実行時に少しスピードアップします。

ただし、このWebページを開いた後は閉じられなかったため、プログラムが終了後に手動で閉じる必要があります。Webページが表示されていない場合、手動で閉じることはできません。コードのコメント部分は、Webページを閉じるためのものです。NavigateはURLです。

情報のクロールを開始するには、Webページが完全に読み込まれるのを待つ必要があります。(ここから、すべてのコードをWithコードブロックに記述する必要があります)

While .ReadyState <> 4 Or .Busy
   DoEvents
Wend

BusyはWebページの忙しい状態であり、ReadyStateはHTTPの5つの準備完了状態であり、次となります。

  • 0:要求は初期化されていません(open()はまだ呼び出されていません)。
  • 1:要求は確立されましたが、まだ送信されていません(send()は呼び出されていません)。
  • 2:要求が送信され、処理されています(通常、コンテンツヘッダーは応答から取得できます)。
  • 3:要求は処理されています。通常、一部のデータは応答で使用できますが、サーバーは応答の生成を完了していません。
  • 4:応答が完了しました。サーバーの応答を取得して使用できます。

情報を取得する

最初にページ上のすべてのコンテンツを取得し、後で有用な部分をフィルタしてから、コンテンツの取得に条件をつけます。

 Set dmt = .Document
        For i = 0 To dmt.all.Length - 1
            Set htMent = dmt.all(i)
            With ActiveSheet
                .Cells(i + 2, "A") = htMent.tagName
                .Cells(i + 2, "B") = TypeName(htMent)
                .Cells(i + 2, "C") = htMent.ID
                .Cells(i + 2, "D") = htMent.Name
                .Cells(i + 2, "E") = htMent.Value
                .Cells(i + 2, "F") = htMent.Text
                .Cells(i + 2, "G") = htMent.innerText
            End With
        Next i

このコードはJSに似ています。Webページ上のすべてのノードを、IE.Document.allから見つける必要があります。 他にもいくつかの方法があります。

  • getElementById(“IDName”):IDNameが内部にある最初のタグを返します。
  • getElementsByName(“a”) :すべての&lt;a&gt;タグを返します。返す値は集合です。
  • getElementsByClassName(“css”):スタイル名がcssで、返す値が集合であるすべてのタグを返します。

これらは、すべてのページコンテンツを取得した後、有効な情報をフィルタするために使用すると便利です。もちろん、allはall(“IDName”)とall.IDNameに使用されるため、allを使用するのが最適です。

上記のコードによって返されるプロパティ値は基本的なHTMLコンテンツであるため、1つずつ説明しません。

情報を入力する

Webで情報を抽出するために、Pythonをお薦めです。ほとんどの人はExcelを使用してページのコンテンツを自動的に入力し、フォームをWebページに直接提出し、アンケート入力などの多くの作業が省けます。Webページのコンテンツを取得した後、入力するのはさらに簡単です。ページラベルのValueプロパティに値を直接割り当てるだけで済みます。

ただし、テキストボックス以外、ドロップダウンメニューやラジオボタンなど、Valueラベルがない場合があります。これらのコンテンツに値を割り当てるには、HTMLの基本的な知識が必要です。

'ドロップダウンメニューの選択
.all("select")(0).Selected = True
'ラジオボタンの選択
.all("radio").Checked = True
'チェックボタンの選択
.all("checkbox").Checked = True

ドロップダウンメニューはselectタグであり、各オプションはオプションタグ内にあるため、集合を返すには、対応するSelectedプロパティをTrueに変更するオプションを選択する必要があります。ラジオボタンとチェックボタンはどちらもinputタグです。違いは、タイプがradioとcheckboxであるということです。オプションを選択するには、対応するCheckedプロパティを変更する必要があります。

データインターフェース

一部のAPIを直接取得できる場合もあります。もちろん、APIを介してデータを返す方が、Webページを開くよりも便利で迅速であり、使用する方法も多少異なります。

リクエストインターフェース

例えば、インターネットから市内の無料WIFIにクエリできるAPIを取得し、次のコードを使用してExcelインターフェイスからアクセスします。(これはただの例であり、このWebサイトは実際には存在しないことに注意してください)

Dim http
  Set http = CreateObject("Microsoft.XMLHTTP")
  http.Open "GET", "http://api.awebsitenotexist.com/Wifi/QueryByCity", False
  http.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
  http.send "key=[AppKey]&city=tokoy&page=1"

この場合、作成したオブジェクトはIEではなく、HTTPオブジェクトです。 ここではAjaxのOpenメソッドが使用され、GETはデータ送信メソッドです。2番目のパラメーターはインターフェースアドレス、3番目のパラメーターはリクエストメソッドが非同期かどうかを指定するためのものです。このAPIにアカウントとパスワードがある場合は、4番目と5番目のパラメーターにそれらを記述します。

setRequestHeaderは、HTTPプロトコルヘッダーファイルをインターフェイスに送信し、最後に、sendの内容はインターフェイスパラメータです。もちろん、このQueryStringはURLに直接書き込むこともでき、空の文字列を送信するだけです。

インターフェーを返す

インターフェイスを返す方法は非常に簡単です。

If http.Status = 200 Then Range("A1").Value = http.responseText

ここでのHTTPステータスは再び200に変更されました。これは、前に述べたものとは異なります。興味がある場合は、特定のステータスを確認できます。

ただし、インターフェイスはJSONまたはXMLのいずれかを返すため、Excelでの処理には非常に不便です。 ここで、JSONを処理するためのメソッドを提供します。これは、インターネット上にあるクラスモジュールです。具体的な内容は付録にあります。 このclsJSONクラスモジュールを追加すると、JSONの処理が非常に簡単になります。

上記のコードを次のように変更します。

 If http.Status = 200 Then
     Dim json$
     json = http.responseText
     Dim objJSON As New clsJSON, dicJSON As Object
     Set dicJSON = objJSON.parse(json)
     
     For i = 1 To dicJSON("result")("data").Count
       Sheet1.Cells(i + 1, 1) = dicJSON("result")("data")(i)("name")
       Sheet1.Cells(i + 1, 2) = dicJSON("result")("data")(i)("intro")
       Sheet1.Cells(i + 1, 3) = dicJSON("result")("data")(i)("address")
     Next i
  End If

また、インターフェイスから返された例を付録に入れ、インターフェイスから返されたオブジェクト名と配列名に従ってdicJSONの後にあるコンテンツを変更するだけです。 JSONを処理するためのこのモジュールは、VBAの辞書+集合の原則を使用するため、データ処理後の呼び出しメソッドも、辞書と集合を参照します。

上記は、Excel + VBAを使用してWebページを操作した個人的な経験です。これが、困っている人の助けになることを願っています。

付録1:JSONを処理するためのVBAのクラスモジュール

Option Explicit
'================================
' JSONを処理するためのVBAのクラスモジュール
'
' https://www.ceodata.com
'================================
Const INVALID_JSON      As Long = 1
Const INVALID_OBJECT    As Long = 2
Const INVALID_ARRAY     As Long = 3
Const INVALID_BOOLEAN   As Long = 4
Const INVALID_NULL      As Long = 5
Const INVALID_KEY       As Long = 6

Private Sub Class_Initialize()

End Sub


Private Sub Class_Terminate()

End Sub

Public Function parse(ByRef str As String) As Object

    Dim index As Long
    index = 1
    
    On Error Resume Next

    Call skipChar(str, index)
    Select Case Mid(str, index, 1)
    Case "{"
        Set parse = parseObject(str, index)
    Case "["
        Set parse = parseArray(str, index)
    End Select

End Function

Private Function parseObject(ByRef str As String, ByRef index As Long) As Object

    Set parseObject = CreateObject("Scripting.Dictionary")
    
    ' "{"
    Call skipChar(str, index)
    If Mid(str, index, 1) <> "{" Then Err.Raise vbObjectError + INVALID_OBJECT, Description:="char " & index & " : " & Mid(str, index)
    index = index + 1
    
    Do
    
        Call skipChar(str, index)
        If "}" = Mid(str, index, 1) Then
            index = index + 1
            Exit Do
        ElseIf "," = Mid(str, index, 1) Then
            index = index + 1
            Call skipChar(str, index)
        End If
        
        Dim key As String
        
        ' add key/value pair
        parseObject.Add key:=parseKey(str, index), Item:=parseValue(str, index)
        
    Loop

End Function

Private Function parseArray(ByRef str As String, ByRef index As Long) As Collection

    Set parseArray = New Collection
    
    ' "["
    Call skipChar(str, index)
    If Mid(str, index, 1) <> "[" Then Err.Raise vbObjectError + INVALID_ARRAY, Description:="char " & index & " : " + Mid(str, index)
    index = index + 1
    
    Do
        
        Call skipChar(str, index)
        If "]" = Mid(str, index, 1) Then
            index = index + 1
            Exit Do
        ElseIf "," = Mid(str, index, 1) Then
            index = index + 1
            Call skipChar(str, index)
        End If
        
        ' add value
        parseArray.Add parseValue(str, index)
        
    Loop

End Function

Private Function parseValue(ByRef str As String, ByRef index As Long)

    Call skipChar(str, index)
    
    Select Case Mid(str, index, 1)
    Case "{"
        Set parseValue = parseObject(str, index)
    Case "["
        Set parseValue = parseArray(str, index)
    Case """", "'"
        parseValue = parseString(str, index)
    Case "t", "f"
        parseValue = parseBoolean(str, index)
    Case "n"
        parseValue = parseNull(str, index)
    Case Else
        parseValue = parseNumber(str, index)
    End Select

End Function

Private Function parseString(ByRef str As String, ByRef index As Long) As String

    Dim quote   As String
    Dim char    As String
    Dim code    As String
    
    Call skipChar(str, index)
    quote = Mid(str, index, 1)
    index = index + 1
    Do While index > 0 And index <= Len(str)
        char = Mid(str, index, 1)
        Select Case (char)
        Case "\"
            index = index + 1
            char = Mid(str, index, 1)
            Select Case (char)
            Case """", "\\", "/"
                parseString = parseString & char
                index = index + 1
            Case "b"
                parseString = parseString & vbBack
                index = index + 1
            Case "f"
                parseString = parseString & vbFormFeed
                index = index + 1
            Case "n"
                parseString = parseString & vbNewLine
                index = index + 1
            Case "r"
                parseString = parseString & vbCr
                index = index + 1
            Case "t"
                parseString = parseString & vbTab
                index = index + 1
            Case "u"
                index = index + 1
                code = Mid(str, index, 4)
                parseString = parseString & ChrW(Val("&h" + code))
                index = index + 4
            End Select
        Case quote
            index = index + 1
            Exit Function
        Case Else
            parseString = parseString & char
            index = index + 1
        End Select
    Loop

End Function

Private Function parseNumber(ByRef str As String, ByRef index As Long)

    Dim value   As String
    Dim char    As String
    
    Call skipChar(str, index)
    Do While index > 0 And index <= Len(str)
        char = Mid(str, index, 1)
        If InStr("+-0123456789.eE", char) Then
            value = value & char
            index = index + 1
        Else
            If InStr(value, ".") Or InStr(value, "e") Or InStr(value, "E") Then
                parseNumber = CDbl(value)
            Else
                parseNumber = CInt(value)
            End If
            Exit Function
        End If
    Loop


End Function

Private Function parseBoolean(ByRef str As String, ByRef index As Long) As Boolean

    Call skipChar(str, index)
    If Mid(str, index, 4) = "true" Then
        parseBoolean = True
        index = index + 4
    ElseIf Mid(str, index, 5) = "false" Then
        parseBoolean = False
        index = index + 5
    Else
        Err.Raise vbObjectError + INVALID_BOOLEAN, Description:="char " & index & " : " & Mid(str, index)
    End If

End Function

Private Function parseNull(ByRef str As String, ByRef index As Long)

    Call skipChar(str, index)
    If Mid(str, index, 4) = "null" Then
        parseNull = Null
        index = index + 4
    Else
        Err.Raise vbObjectError + INVALID_NULL, Description:="char " & index & " : " & Mid(str, index)
    End If

End Function

Private Function parseKey(ByRef str As String, ByRef index As Long) As String

    Dim dquote  As Boolean
    Dim squote  As Boolean
    Dim char    As String
    
    Call skipChar(str, index)
    Do While index > 0 And index <= Len(str)
        char = Mid(str, index, 1)
        Select Case (char)
        Case """"
            dquote = Not dquote
            index = index + 1
            If Not dquote Then
                Call skipChar(str, index)
                If Mid(str, index, 1) <> ":" Then
                    Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
                End If
            End If
        Case "'"
            squote = Not squote
            index = index + 1
            If Not squote Then
                Call skipChar(str, index)
                If Mid(str, index, 1) <> ":" Then
                    Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
                End If
            End If
        Case ":"
            If Not dquote And Not squote Then
                index = index + 1
                Exit Do
            End If
        Case Else
            If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", char) Then
            Else
                parseKey = parseKey & char
            End If
            index = index + 1
        End Select
    Loop

End Function

Public Sub skipChar(ByRef str As String, ByRef index As Long)

    While index > 0 And index <= Len(str) And InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Mid(str, index, 1))
        index = index + 1
    Wend

End Sub

Public Function toString(ByRef obj As Variant) As String

    Select Case VarType(obj)
        Case vbNull
            toString = "null"
        Case vbDate
            toString = """" & CStr(obj) & """"
        Case vbString
            toString = """" & encode(obj) & """"
        Case vbObject
            Dim bFI, i
            bFI = True
            If TypeName(obj) = "Dictionary" Then
                toString = toString & "{"
                Dim keys
                keys = obj.keys
                For i = 0 To obj.Count - 1
                    If bFI Then bFI = False Else toString = toString & ","
                    Dim key
                    key = keys(i)
                    toString = toString & """" & key & """:" & toString(obj(key))
                Next i
                toString = toString & "}"
            ElseIf TypeName(obj) = "Collection" Then
                toString = toString & "["
                Dim value
                For Each value In obj
                    If bFI Then bFI = False Else toString = toString & ","
                    toString = toString & toString(value)
                Next value
                toString = toString & "]"
            End If
        Case vbBoolean
            If obj Then toString = "true" Else toString = "false"
        Case vbVariant, vbArray, vbArray + vbVariant
            Dim sEB
            toString = multiArray(obj, 1, "", sEB)
        Case Else
            toString = Replace(obj, ",", ".")
    End Select

End Function

Private Function encode(str) As String
    
    Dim i, j, aL1, aL2, c, p

    aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9)
    aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74)
    For i = 1 To Len(str)
        p = True
        c = Mid(str, i, 1)
        For j = 0 To 7
            If c = Chr(aL1(j)) Then
                encode = encode & "\" & Chr(aL2(j))
                p = False
                Exit For
            End If
        Next

        If p Then
            Dim a
            a = AscW(c)
            If a > 31 And a < 127 Then
                encode = encode & c
            ElseIf a > -1 Or a < 65535 Then
                encode = encode & "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)
            End If
        End If
    Next
End Function

Private Function multiArray(aBD, iBC, sPS, ByRef sPT)   ' Array BoDy, Integer BaseCount, String PoSition
    Dim iDU, iDL, i ' Integer DimensionUBound, Integer DimensionLBound
    On Error Resume Next
    iDL = LBound(aBD, iBC)
    iDU = UBound(aBD, iBC)
    
    Dim sPB1, sPB2  ' String PointBuffer1, String PointBuffer2
    If Err.Number = 9 Then
        sPB1 = sPT & sPS
        For i = 1 To Len(sPB1)
            If i <> 1 Then sPB2 = sPB2 & ","
            sPB2 = sPB2 & Mid(sPB1, i, 1)
        Next
'        multiArray = multiArray & toString(Eval("aBD(" & sPB2 & ")"))
        multiArray = multiArray & toString(aBD(sPB2))
    Else
        sPT = sPT & sPS
        multiArray = multiArray & "["
        For i = iDL To iDU
            multiArray = multiArray & multiArray(aBD, iBC + 1, i, sPT)
            If i < iDU Then multiArray = multiArray & ","
        Next
        multiArray = multiArray & "]"
        sPT = Left(sPT, iBC - 2)
    End If
    Err.Clear
End Function

付録2:JSONの返す例

{
"resultcode":"200",
"reason":"ReturnSuccessd!",
"result":{
"data":[
{
"resultcode":"200",
"reason":"ReturnSuccessd!",
"result":{
"data":[

{
"name":"千葉県東金市",
"intro":"東金市田間2",
"address":"千葉県東金市田間",
"google_lat":"35.566216",
"google_lon":"140.367542",
"baidu_lat":"35.566216",
"baidu_lon":"140.367542",
"province":"千葉県",
"city":"東金市"
},

{
"name":"千葉県成田市成田空港",
"intro":"成田市成田空港第2ビル",
"address":"千葉県成田市成田空港第2ビル",
"google_lat":"35.7739533",
"google_lon":"140.387067",
"baidu_lat":"35.7739533",
"baidu_lon":"140.387067",
"province":"千葉県",
"city":"成田市"
},

{
"name":"東京羽田国際空港",
"intro":"",
"address":"東京羽田空港第1ビル",
"google_lat":"35.5524122",
"google_lon":"139.783877",
"baidu_lat":"35.5524122",
"baidu_lon":"139.783877",
"province":"東京都",
"city":"東京"
},

{
"name":"大阪府関西国際空港",
"intro":"",
"address":"大阪府関西国際空港第1ビル",
"google_lat":"34.4351328",
"google_lon":"135.242776",
"baidu_lat":"34.4351328",
"baidu_lon":"135.242776",
"province":"大阪府",
"city":"大阪"
},

{
"name":"北海道千歳空港",
"intro":"",
"address":"北海道千歳空港",
"google_lat":"42.7876659",
"google_lon":"141.680226",
"baidu_lat":"42.7876659",
"baidu_lon":"141.680226",
"province":"北海道",
"city":"千歳"
},

{
"name":"福岡空港",
"intro":"福岡県福岡市",
"address":"福岡県福岡市福岡空港",
"google_lat":"33.5974285",
"google_lon":"130.448143",
"baidu_lat":"33.5974285",
"baidu_lon":"130.448143",
"province":"福岡県",
"city":"福岡市"
},

{
"name":"千葉県成田市",
"intro":"ok",
"address":"千葉県成田市芝山千代田駅",
"google_lat":"35.754083",
"google_lon":"140.399583",
"baidu_lat":"35.754083",
"baidu_lon":"140.399583",
"province":"千葉県",
"city":"成田市"
},

{
"name":"千葉県佐倉市",
"intro":"",
"address":"千葉県佐倉市青木動物病院",
"google_lat":"35.7088979",
"google_lon":"140.2218955",
"baidu_lat":"35.7088979",
"baidu_lon":"140.2218955",
"province":"千葉県",
"city":"佐倉市"
},

{
"name":"千葉県四街道市",
"intro":"四街道市つぼみ幼稚園",
"address":"千葉県四街道市つぼみ幼稚園",
"google_lat":"35.6753280",
"google_lon":"140.1574000",
"baidu_lat":"35.6753280",
"baidu_lon":"140.1574000",
"province":"千葉県",
"city":"四街道市"
},

{
"name":"東京都足立区",
"intro":"",
"address":"足立区足立消防署",
"google_lat":"35.7749365",
"google_lon":"139.8028922",
"baidu_lat":"35.7749365",
"baidu_lon":"139.8028922",
"province":"東京都",
"city":"東京"
}
],
"pageinfo":{
"pnums":20,
"current":1
	}
	}
}
Share

コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です