VBAでIE操作、webデータスクレイピングツール作ってみました

VBAスクレイパーVer１（スクレイピングツール）
1. IEスクレイピングツール　VBAスクレイパーVer1
主要コード解説
その他のVBAツールのご紹介
1. 練習用電光掲示板

VBAスクレイパーVer１（スクレイピングツール）

ヤフオクサイトのにアクセスしてご希望のワードで検索後、商品リストを一覧にしてエクセルのワークシートに張り付けするVBAツールです。（10日間のお試し版です）

VBAにて商品情報を収集しますが、ヤフオクサイト様のサイトデザインの変更や様々な仕様変更などで、ツールがうまく動作しなくなることが予想されます。その場合はご相談いただければ対処いたします。（2020年8月現在動作確認済み）

ベクター（フトウェア流通サイト）さんにて販売予定ですが、ベクターさんの事情で（コロナ禍で業務縮小中とのこと）登録に時間がかかっていて未だに登録できずにいますが、こちらからダウンロードできるようにしておきました。

ダウンロードファイルは圧縮しています。解凍してお使いください。（このファイルはエクセル2013で作成しています。お使いのPCにエクセルが必要です）

ファイルには10日間の試用期間が設定され無料でお試しいただけます。

IEスクレイピングツール　VBAスクレイパーVer1

1 ファイル 107.23 KB

ダウンロード

その後も使いたい場合はベクター様から購入できます。

作者: AYUTOKUNN

現在登録申請中ですが、作者ページで本ツールがまだ表示されていない場合は、登録完了までしばらくお待ちください。

主要コード解説

IE（インターネットエクスプローラー）を起動

１～３行目　objecIEを宣言して、”InternetExplorer.Application”を登録する。

６～11行目　ブラウザの大きさと開く位置を調整。

14行目　　　ブラウザを表示。

17～20行目　ブラウザにヤフオクのurlを渡してサイトを開く。

　　Dim objecIE As InternetExplorer
    'IE起動
    Set objecIE = CreateObject("InternetExplorer.Application")
　　
　　'ブラウザの位置大きさ指定
    With objecIE
        .Top = 50  'Y位置（上下）
        .Left = 50  'X位置（左右）
        .Width = 1000  'IEウィンドウの幅
        .Height = 1000  'IEウィンドウの高さ
    End With

    'ブラウザを表示（空の状態）
    objecIE.Visible = True
    
    'urlを指定（ヤフオクに限定）
    url = Cells(3, 2).Value
　　
　　'ブラウザにurlを渡してヤフオクを開く
    acse objecIE, url   '（待機して3秒待ち）

　　Dim objecIE As InternetExplorer

'IE起動

Set objecIE = CreateObject("InternetExplorer.Application")

　　'ブラウザの位置大きさ指定

With objecIE

.Top = 50 'Y位置（上下）

.Left = 50 'X位置（左右）

.Width = 1000 'IEウィンドウの幅

.Height = 1000 'IEウィンドウの高さ

End With

'ブラウザを表示（空の状態）

objecIE.Visible = True

'urlを指定（ヤフオクに限定）

url = Cells(3, 2).Value

　　'ブラウザにurlを渡してヤフオクを開く

acse objecIE, url '（待機して3秒待ち）

ヤフオクサイトを開く

上図の20行目のサブプロシージャ内容でヤフオクサイトにアクセスする。

'ヤフオクにアクセスして開く
Sub acse(ByRef objecIE As Object, ByVal url As String)
    'ヤフオク開く
    objecIE.Navigate url
    
    'IE待機
    IEtaiki objecIE
    
    '3秒間止まる（ここで待ちを入れないとエラーになる）
    sannbyoumati 3

End Sub

'ヤフオクにアクセスして開く

Sub acse(ByRef objecIE As Object, ByVal url As String)

'ヤフオク開く

objecIE.Navigate url

'IE待機

IEtaiki objecIE

'3秒間止まる（ここで待ちを入れないとエラーになる）

sannbyoumati 3

End Sub

'3秒停止関数
Function sannbyoumati(ByVal sec As Integer)
    Dim fTime As Date
 
    fTime = DateAdd("s", sec, Now)
 
    While Now < fTime
        DoEvents
    Wend
End Function

'3秒停止関数

Function sannbyoumati(ByVal sec As Integer)

Dim fTime As Date

fTime = DateAdd("s", sec, Now)

While Now < fTime

DoEvents

Wend

End Function

出品データを収集する

'***************************************************************
    '■■■■ページを解析してデータを読み込むメインの処理開始■■
    '***************************************************************
    
    'ページ当たりの表示する件数表示を調べる（規定は５０件になっている）
    Dim hyj_kensuu As Integer
    hyj_kensuu = kennsuu(objecIE)
    
    '総件数と比較してページを切り替えする繰り返す回数を計算
    Dim forMax As Variant
    forMax = Application.RoundUp(sousuu / hyj_kensuu, 0) '少数切り上げ
    
    For i = 1 To forMax
        If i = 1 Then
            titlset objecIE     '１回目の処理
        ElseIf i >= 2 Then
            If tsugiPaige(objecIE) = True Then
                titlset objecIE 'ページを変えて2回目以降の処理
            Else
                Exit For
            End If
        End If
    Next

'***************************************************************

'■■■■ページを解析してデータを読み込むメインの処理開始■■

'***************************************************************

'ページ当たりの表示する件数表示を調べる（規定は５０件になっている）

Dim hyj_kensuu As Integer

hyj_kensuu = kennsuu(objecIE)

'総件数と比較してページを切り替えする繰り返す回数を計算

Dim forMax As Variant

forMax = Application.RoundUp(sousuu / hyj_kensuu, 0) '少数切り上げ

For i = 1 To forMax

If i = 1 Then

titlset objecIE '１回目の処理

ElseIf i >= 2 Then

If tsugiPaige(objecIE) = True Then

titlset objecIE 'ページを変えて2回目以降の処理

Else

Exit For

End If

データをシートに転記する

15、16行目がブラウザから必要なデータを取り出すための重要なコードになります。

ブラウザを表示している状態で、「F12キー」を押すと、表示しているサイトの内容を構成している開発者用のツールが表示されます。

こんな感じで、上半分はサイトの情報で、下半分がその情報を構成しているHTMLファイルを含んだ開発者ツールです。

使い方はやや難解ですが、しばらくの間色々いじくって見てやっとその動作がわかったようです。欲しい情報の部分のHTMLタグとやらを自動的に表示してくれるようです。そのタグを手掛かりに取り出す情報の部分を切り取る作業を下のコードでしています。

下図の例ではエクスプローラでヤフオクサイトを開いて、検索窓に「エクセル」と書き込んで検索したとき最初に表示された画面の状態です。この状態で「F12キー」を押すと下半分に開発者用のツールが表示された状態です。

上半分の出品情報で「すべて」のタブを見ると8980件となっています。これは文字通りエクセル関連の出品情報が8980件あるという意味です。この状況で出品タイトル、価格情報などを一覧表で見たいというシチュエーションがあるとします。この様なネット情報からデータを一覧に取り出すにはデータスクレイピングという技術を利用します。エクセルのVBAにはこの様なネット情報を取り出すためのツールが組み込まれていますから、これを利用します。

上半分のこの様なウェブ情報はHTMLという言語でできているのだそうです。HTMLにはタグと呼ばれる目次みたいなものがついていてそのタグを目的にしてデータを取り出すことができるんです。

そのタグ情報を見つけるために利用するのが、F12キーで表示される開発者ツールなのです。

開発者ツールの使い方

出品タイトルを取り出すには、①に赤丸で囲った部分のアイコンを一回クリックします。

そして青矢印で示したようにマウスカーソルをタイトル部分に移動させクリックするとさらに矢印で示すように、②の様な薄い青色で反転表示した部分が表示され注意してみると、タイトル情報が書かれているHTMLが現れます。この中から具体的にタイトルを取り出すには

データスクレイピングの肝　objecIE.Document.getElementsByTagName

objecIE.Document.getElementsByTagName(“h3”) を使います。

一番最後のh3とは　②のところにあるタグの名前です。このh3タグはその上のliというタグの中に含まれていることがわかります。（ですから、liタグやその下のdivタグ使っても、OKなんです。更にclassの部分を使ってもできるんです）ここではh3に絞って解説します。

どうやらこのh3タグにタイトルやその他の情報が書き込まれていることがわかります。そして、更にaタグがあってこの中に赤文字でtitle＝”即決　Microsoft　office2019最新版アプリ……”という部分を見つけることが出ます。

これでh3タグのtitle＝をコードで見つければタイトルを取り出すことができるんです。

このh3タグは各出品データごとに存在しますから、For Eachを使ってこのh3タグ情報を順番に取り出してやるんです。

For Each objectag In objecIE.Document.getElementsByTagName(“h3”)

そしてこのh3タグの中から更に、title＝を見つけるのが次のコードになります。

If InStr(objectag.outerHTML, “title=”””) > 0 Then

objectag.outerHTMLこの部分がaタグの内容すべてを表していますから、この中にtitle=が含まれている場合は0以上が帰ってくるのでタイトルが存在することがわかりますね。（ここでは存在することがわかればいいからその位置を知る必要がないので、＞０とします）

例
InStr　は第一引数の中に、第二引数が含まれていればその位置を返します

index　＝　InStr（”あいうえおかきくけこ”,”おかき”）の場合
indexは５になります

そして、具体的にタイトルを取りだすには

str = objectag.innerTextとするとタイトルだけを取り出すことができます。

そして、シートのどの位置にstrを書き込むか調べて（新規入力可能なセルの行位置）書き込みます。

objectag.innerTextでデータ取得

上図でのタイトルを取り出すときの要領で今度は価格情報を取り出してみます。

obIE.Document.getElementsByClassName(“Product__priceInfo”）

上図の例ではgetElementsByTagNameでしたが、今度はgetElementsByClassNameを使います。

前回同様　For Each　を使って

For Each objprice In obIE.Document.getElementsByClassName(“Product__priceInfo”)とします。

開発ツールを使ってdiv、spanのタグのところの▼印をクリックして開けて中を見てみると価格情報が書かれているのが確認できます。つまり、このクラスネームを指定して探せば価格情報を取り出すことができるんです。具体的な取り出し方はobjectag.outerHTML　と　objectag.innerTextを使いますがouterHTML、innerTextをウェブで調べてみましょう。そして取り出し方を自分なりに工夫することが必要です、サイトの情報は常に変化します。そのHTMLコードの書き方も変化するので一つの取り出し方を書いてもすぐに無意味になってしまいます。どうやったらほしい情報を取り出せるか研究しないといけません。

‘確認の方法—-
’変数の確認は、Debug.Print　を使ってやるのが普通なんですが筆者の場合はMsgBox
’を使っています。次のようにして内容を確認し必要なくなったらコメント化します。Dim x As String
Dim x2 As String
x = objprice.outerText
MsgBox x
x = objprice.outerHTML
MsgBox xx2 = objprice.innerText
MsgBox x2
x2 = objprice.innerHTML
MsgBox x2
‘—

innerHTML　ではタグのコードを含んだ要素全体が取得でき
innerText　では要素のText部分だけを取得できるようです。
outerとinnerの違いについてはよく理解していません。

エクセルVBAのIE（InternetExplorer）制御サイトさんの解説を参考にさせていただいています。

実際、innerText　で動かしてみると、”現在500円”とか”即決500円”なっています。文字列と数値が入り交ざっているのでこのままでいいならあまり複雑にならないのですが、数値だけほしい場合はこの中から取り出す工夫をしなければならないのでコードが複雑になってしまいました。もっといい方法があるような気がしますが、いまのところこれが限界でした。

以下が取得したデータから数値だけ取り出してシートに書き込むプロシージャになります。

Sub price1(ByRef obIE As Object)
'現在の価格と即決の価格
    Dim r_max As Long
    Dim genzai As String
    Dim sokket As String
    Dim i As Integer
    Dim n1 As Integer
    Dim n2 As Integer
    Dim n3 As Integer
    
    Dim objprice As Object
    
    '----------------------------------------------
    For Each objprice In obIE.Document.getElementsByClassName("Product__priceInfo")
    n1 = InStr(objprice.outerText, "即決")
    n2 = InStr(objprice.outerText, "円")
    n3 = InStr(n2 + 1, objprice.outerText, "円")
    '確認----
    'Dim x As String
    'Dim x2 As String
        'x = objprice.outerText
        'x = objprice.outerHTML
        'MsgBox x
        'x2 = objprice.innerText
        'x2 = objprice.innerHTML
        'MsgBox x2
    '---
    
        If Mid(objprice.outerText, 1, 2) = "現在" Then
            '即決があるか調べる
            If n1 > 0 Then
                '連続表記をそれぞれ二つに分ける
                genzai = Mid(objprice.outerText, 1, n1 - 1)
                sokket = Mid(objprice.outerText, n1, n3)
            Else
                '即決がなければ現在だけなので
                genzai = objprice.outerText
                sokket = "--"
            End If
        ElseIf Mid(objprice.outerText, 1, 2) = "即決" Then
            '現在があるか調べる
            n1 = InStr(objprice.outerText, "現在")
            If n1 > 0 Then
                '最初が即決なら現在は無いと規定できるので下の2行はいらない
                'genzai = Mid(objprice.outerText, 1, n1 - 1)
                'sokket = Mid(objprice.outerText, n1)
            Else
                genzai = "--"
                sokket = objprice.outerText
            End If
            
        End If
        '--------------------------------------------------
        r_max = row_Max(3)  '新規入力行位置をC列指定で取得
        
        ActiveSheet.Cells(r_max, 3).Value = suujidake(genzai)
        ActiveSheet.Cells(r_max, 3).HorizontalAlignment = xlCenter
        ActiveSheet.Cells(r_max, 4).Value = suujidake(sokket)
        ActiveSheet.Cells(r_max, 4).HorizontalAlignment = xlCenter
    Next objprice
End Sub

Sub price1(ByRef obIE As Object)

'現在の価格と即決の価格

Dim r_max As Long

Dim genzai As String

Dim sokket As String

Dim i As Integer

Dim n1 As Integer

Dim n2 As Integer

Dim n3 As Integer

Dim objprice As Object

'----------------------------------------------

For Each objprice In obIE.Document.getElementsByClassName("Product__priceInfo")

n1 = InStr(objprice.outerText, "即決")

n2 = InStr(objprice.outerText, "円")

n3 = InStr(n2 + 1, objprice.outerText, "円")

'確認----

'Dim x As String

'Dim x2 As String

'x = objprice.outerText

'x = objprice.outerHTML

'MsgBox x

'x2 = objprice.innerText

'x2 = objprice.innerHTML

'MsgBox x2

'---

If Mid(objprice.outerText, 1, 2) = "現在" Then

'即決があるか調べる

If n1 > 0 Then

'連続表記をそれぞれ二つに分ける

genzai = Mid(objprice.outerText, 1, n1 - 1)

sokket = Mid(objprice.outerText, n1, n3)

Else

'即決がなければ現在だけなので

genzai = objprice.outerText

sokket = "--"

End If

ElseIf Mid(objprice.outerText, 1, 2) = "即決" Then

'現在があるか調べる

n1 = InStr(objprice.outerText, "現在")

If n1 > 0 Then

'最初が即決なら現在は無いと規定できるので下の2行はいらない

'genzai = Mid(objprice.outerText, 1, n1 - 1)

'sokket = Mid(objprice.outerText, n1)

Else

genzai = "--"

sokket = objprice.outerText

End If

'--------------------------------------------------

r_max = row_Max(3) '新規入力行位置をC列指定で取得

ActiveSheet.Cells(r_max, 3).Value = suujidake(genzai)

ActiveSheet.Cells(r_max, 3).HorizontalAlignment = xlCenter

ActiveSheet.Cells(r_max, 4).Value = suujidake(sokket)

ActiveSheet.Cells(r_max, 4).HorizontalAlignment = xlCenter

Next objprice

End Sub

このように obIE.Document.getElementsByClassNameや

objecIE.Document.getElementsByTagNameなどを使てデータを取得してそのデータを様々に加工し利用することができるのです。

データ転記の肝、ワークシートの新規入力行を知る

取得したデータをワークシートに書き込むために、シートのどの位置に書き込むか指定することが必要です

'現在のシートのデータを入れるべき最終行を返す
Function row_Max(siteiRetu As Integer) As Long
    '　　　　　　　　　　　　　（2列目指定している↓）
    row_Max = ActiveSheet.Cells(Rows.Count, siteiRetu).End(xlUp).Row + 1
End Function

'現在のシートのデータを入れるべき最終行を返す

Function row_Max(siteiRetu As Integer) As Long

'　　　　　　　　　　　　　（2列目指定している↓）

row_Max = ActiveSheet.Cells(Rows.Count, siteiRetu).End(xlUp).Row + 1

End Function

row_Max = ActiveSheet.Cells(Rows.Count, siteiRetu).End(xlUp).Row + 1この一文が新規入力行の行位置を示します。

Cells(Rows.Count, siteiRetu)…第一引数はワークシートの行数、第二引数は列位置を指定します。

第二引数については、ワークシートに存在するデータベースの内データのある最終行をどの列に見るかを指定します。

あるデータベースでA列とB列にA1～A10までデータがあり、B1～B8までデータがあるとしたとき
（ActiveSheet.Cells(Rows.Count, siteiRetu).End(xlUp).Row + 1　に於いて）
x　＝　Cells(Rows.Count, １)　と、A列を見るとするとｘには　11　が入り、
x　＝　Cells(Rows.Count, 2)　と、B列を見るとするとｘには　9　が取得されるということです。どの列を見るかによってデータを入れる行位置が変わってきますから注意が必要です。

最後に、リンクをあてる

元々、どのサイトのデータを見てもたいていはリンクが貼ってあるところが多くあります。ここで扱っているヤフオクでも出品データのタイトルをクリックすると、そのタイトルの専用のリンク先へジャンプするようになっています。

しかし、前項目までで解説したデータを取りだしてワークシートに書き出す処理ではタイトル名は書き出しできましたが、そこにリンクは設定されていません。（ワークシートに書き出されたタイトルをクリックしても何も起こらないということです。）

そこで、この書き出されたタイトルにリンクを張り付ける作業をします。

objecIE.Document.getElementsByTagName(“h3”)　で得られるHTMLデータにはそのリンクデータが含まれています。

下図の青矢印のところがそれです。

赤色アンダーラインの部分でhref＝”https://・・・・・～・・・”ここがリンク先情報になっています。

aタグ（アンカー）のエイチレフ属性というらしいです。これを書き出したタイトル名に当て込みます。

下図がそのプロシージャです。

Sub rinkhari(ByRef objIE As Object, str As String, gyou As Long)
Dim ur As String
'URLをリンクする

    Dim anchor As HTMLAnchorElement
    For Each anchor In objIE.Document.Links
        If InStr(anchor.outerHTML, str) > 0 Then
            ur = anchor.href
            'リンクを張る
            ActiveSheet.Hyperlinks.Add anchor:=ActiveSheet.Cells(gyou, 2), Address:=ur
        End If
    Next anchor
End Sub

Sub rinkhari(ByRef objIE As Object, str As String, gyou As Long)

Dim ur As String

'URLをリンクする

Dim anchor As HTMLAnchorElement

For Each anchor In objIE.Document.Links

If InStr(anchor.outerHTML, str) > 0 Then

ur = anchor.href

'リンクを張る

ActiveSheet.Hyperlinks.Add anchor:=ActiveSheet.Cells(gyou, 2), Address:=ur

End If

Next anchor

End Sub

このプロシージャの第一引数はHTMLオブジェクトです。第二引数はタイトル名です。第三引数はタイトルが書き出されている行位置です。

For Each anchor In objIE.Document.Links

繰り返し処理でanchorにはオブジェクトのリンク部分だけが取り出されます。

このオブジェクトのouterHTMLに引数のタイトル名が含まれていればそのhrefを取りだします。

最後に、ActiveSheet.Hyperlinks.Add anchor　:=　ActiveSheet.Cells(gyou, 2), Address:=ur

ワークシートのハイパーリンクプロパティーに、書き出された行位置にあるタイトル名の列にhrefが示すアドレスを当て込んでいます。

これでワークシートのタイトル名が青くなってアンダーラインが敷かれます。（クリックするとリンク先にジャンプします）

ここまででこのプログラムのポイントは解説できたと思います。

最後に、以下に全部をコントロールするプロシージャを載せておきます。お役に立てるかわかりませんが、一生懸命頑張ってみました。どうぞよろしくお願いします！！！意味不明？？？

Sub titlset(ByRef objecIE As Object)
    Dim r_max As Long
    Dim objectag As Object
    Dim str As String
    Dim i As Integer
    Dim countcolec As Integer
    
    'プログレスバーのフォームを開く
    UserForm1.Show
    Application.ScreenUpdating = False
    
    countcolec = objecIE.Document.getElementsByTagName("h3").Length
    '----------------------------------
    i = 0
    For Each objectag In objecIE.Document.getElementsByTagName("h3")
        If InStr(objectag.outerHTML, "title=""") > 0 Then
            r_max = row_Max(2)  'B列指定
            
            'A列にインデックス番号を書き出す
            ActiveSheet.Cells(r_max, 1).Value = r_max - 9
            
            'タイトル名を取り出す
            str = objectag.innerText
            ActiveSheet.Cells(r_max, 2).Value = str 'これ一行でOKです
            
            'URLをリンクする
            rinkhari objecIE, str, r_max
        End If
        i = i + 1
        'プログレスバーの進捗を更新表示
        UserForm1.sinkou_val countcolec, i
        'DoEvents
    Next objectag
    
    
    '現在の価格と即決価格をセット
    price1 objecIE
    
    'その他の項目（otherInfo）
    otherinfo objecIE
    otherinfo2 objecIE
    
    '備考の項目
    otherinfo3 objecIE
    
 '--------------------------------
    'プログレスバーを閉じる
    Unload UserForm1
    Application.ScreenUpdating = True
 
End Sub

Sub titlset(ByRef objecIE As Object)

Dim r_max As Long

Dim objectag As Object

Dim str As String

Dim i As Integer

Dim countcolec As Integer

'プログレスバーのフォームを開く

UserForm1.Show

Application.ScreenUpdating = False

countcolec = objecIE.Document.getElementsByTagName("h3").Length

'----------------------------------

i = 0

For Each objectag In objecIE.Document.getElementsByTagName("h3")

If InStr(objectag.outerHTML, "title=""") > 0 Then

r_max = row_Max(2) 'B列指定

'A列にインデックス番号を書き出す

ActiveSheet.Cells(r_max, 1).Value = r_max - 9

'タイトル名を取り出す

str = objectag.innerText

ActiveSheet.Cells(r_max, 2).Value = str 'これ一行でOKです

'URLをリンクする

rinkhari objecIE, str, r_max

End If

i = i + 1

'プログレスバーの進捗を更新表示

UserForm1.sinkou_val countcolec, i

'DoEvents

Next objectag

'現在の価格と即決価格をセット

price1 objecIE

'その他の項目（otherInfo）

otherinfo objecIE

otherinfo2 objecIE

'備考の項目

otherinfo3 objecIE

'--------------------------------

'プログレスバーを閉じる

Unload UserForm1

Application.ScreenUpdating = True

End Sub

その他のVBAツールのご紹介

練習用電光掲示板

1 ファイル 36.71 KB

ダウンロード

詳細はこちらからどうぞ。

エクセルVBAを始めてみましょう。第5回プログラミングの手法応用編、テキストボックスを利用した電光掲示板を作ってみます。

今回は電光掲示板もどきを作ってみます。今回は、電光掲示板風に見えるプログラムを開設します。約12年前に筆者がまだVBAを覚えたてのころ作ったものですから、あまりうまくできていませんが、素人の初心者でもこの程度の物は作れるようになると...

VBAスクレイパーVer１（スクレイピングツール）

IEスクレイピングツール VBAスクレイパーVer1

主要コード解説

IE（インターネットエクスプローラー）を起動

ヤフオクサイトを開く

出品データを収集する

データをシートに転記する

開発者ツールの使い方

データスクレイピングの肝 objecIE.Document.getElementsByTagName

objectag.innerTextでデータ取得

データ転記の肝、ワークシートの新規入力行を知る

最後に、リンクをあてる

その他のVBAツールのご紹介

練習用電光掲示板

コメント

IEスクレイピングツール　VBAスクレイパーVer1

データスクレイピングの肝　objecIE.Document.getElementsByTagName