More than 3 years have passed since last update.

[ExcelVBA]ExcelVBAでスクレイピング！(VBA超初級者編)

Last updated at 2020-04-08Posted at 2020-03-29

#目次

はじめに
概要
サンプルコード
サンプル画像と使用例
終わりに
参考にしたサイト
追記(2020/4/08)

#はじめに
会社でも家庭でも何気に使うExcelファイル。一般的に設計書や家計簿を作る際に使うことが多いであろうが、こんな使い方もあるということを、忘備録も兼ねて投稿する。
#概要
さて、突然だが、ポケモンバトル用ポケモンデータ収集ツールを作ってみた。
(🌟完全に個人の趣味です🌟)
これは、スクレイピングという方法を用いて作成する。
ちなみに、スクレイピングとは、端的に言うと取得した情報を加工することである。(詳しくはココをクリック！)
なお、ポケモンのタマゴ技のデータの抽出がごく一部うまくいかないが、そこは見逃してほしい。

#サンプルコード
今回は、以下の4つのプロシージャを活用する。

Option Explicit
'ご利用の際は、ここから
'#If VBA7 Then
'Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
'#Else
'Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
'#End If
'ここまでをコメントアウトして下さい

Private Sub btnTeamMake_click()
On Error GoTo Err
    
    '新しいメンバーポケモンのシートを作成する
    Dim meinSheet As Worksheet
    Dim templateSheet As Worksheet
    
    Set meinSheet = ThisWorkbook.Worksheets("メインシート")
    Set templateSheet = ThisWorkbook.Worksheets("テンプレート")
    If meinSheet.Range("C4").Value = "" Then
        MsgBox "ポケモンの名前を入力してください。"
        Exit Sub
    Else
        Dim pokemonName As String
        pokemonName = meinSheet.Range("C4").Value
    End If
    
    '新しいメンバーのシートがある場合、シート作成処理を飛ばす。ない場合、シート作成処理発火
    Dim ws As Worksheet
    Dim flg As Boolean
    
    For Each ws In Worksheets
        If ws.Name = pokemonName Then flg = True
    Next ws
    
    If flg = True Then
        Dim newMemberSheet As Worksheet
        Set newMemberSheet = ThisWorkbook.Worksheets(pokemonName)
        newMemberSheet.Activate
    Else
        templateSheet.Copy After:=meinSheet
        ThisWorkbook.ActiveSheet.Name = pokemonName
        Set newMemberSheet = ThisWorkbook.Worksheets(pokemonName)
        newMemberSheet.Range("C5").Value = pokemonName
    End If
    
    'ポケモン徹底攻略サイトをIE(InternetExplorer)で起動
    Dim ieObject  As InternetExplorer
    
    Call ieView(ieObject, "https://yakkun.com/swsh/zukan/" & pokemonName)
    'aタグのリンクをクリックして同じウィンドウで表示
    Dim ieImageObject As Object
    
    For Each ieImageObject In ieObject.document.getElementsByTagName("a")
        If InStr(ieImageObject.innerText, pokemonName) > 0 Then
            ieImageObject.Click
            Call ieCheck(ieObject)
            Exit For
        End If
    Next
    
    Call createNewMemberSheet(ieObject, newMemberSheet, pokemonName)
    ieObject.Quit
Err:
    ieObject.Quit
End Sub

Private Sub ieView(objIE As InternetExplorer, _
           urlName As String, _
           Optional flgView As Boolean = True, _
           Optional ieTop As Integer = 0, _
           Optional ieLeft As Integer = 0, _
           Optional ieWidth As Integer = 600, _
           Optional ieHeight As Integer = 800)
    
    'IE(InternetExplorer)のオブジェクトを作成する
    Set objIE = CreateObject("InternetExplorer.Application")
    
    With objIE
        'IE(InternetExplorer)を表示・非表示
        .Visible = flgView
        .Top = ieTop  'Y位置
        .Left = ieLeft  'X位置
        .Width = ieWidth  '幅
        .Height = ieHeight  '高さ
        '指定したURLのページを表示する
        .navigate urlName
    End With
    'IE(InternetExplorer)が完全表示されるまで待機
    Call ieCheck(objIE)
    
End Sub

Private Sub ieCheck(objIE As InternetExplorer)

    Dim timeOut As Date
    
    '完全にページが表示されるまで待機する
    timeOut = Now + TimeSerial(0, 0, 20)
    Do While objIE.Busy = True Or objIE.readyState <> 4
        DoEvents
        Sleep 1
        If Now > timeOut Then
            objIE.Refresh
            timeOut = Now + TimeSerial(0, 0, 20)
        End If
    Loop
    
    timeOut = Now + TimeSerial(0, 0, 20)
    Do While objIE.document.readyState <> "complete"
        DoEvents
        Sleep 1
        If Now > timeOut Then
            objIE.Refresh
            timeOut = Now + TimeSerial(0, 0, 20)
        End If
     Loop
End Sub

Private Sub createNewMemberSheet(ByVal ieObject As Object, ByVal newMemberSheet As Worksheet, ByVal pokemonName As String)

    'ポケモンの種族値(class属性がleft、liの要素)を抽出
    Dim i As Integer
    
    For i = 1 To ieObject.document.getElementsByClassName("left").Length
        With newMemberSheet
            Select Case i
                Case 1
                    .Range("C11").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                    .Range("C7").Value = ieObject.document.getElementsByTagName("li")(i).innerText
                Case 2
                    .Range("C12").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                    .Range("C8").Value = ieObject.document.getElementsByTagName("li")(i).innerText
                Case 3
                    .Range("C13").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                Case 4
                    .Range("C14").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                Case 5
                    .Range("C15").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                Case 6
                    .Range("C16").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                Case Else
                
            End Select
        End With
        
        '新しいメンバーのポケモンの画像を取得(新しいメンバーの名前が含まれているimgタグ)、シートに貼り付け
        If ieObject.document.images(i).alt = pokemonName Then
            With newMemberSheet.Shapes.AddPicture(ieObject.document.images(i).src, True, False, Selection.Left, Selection.Top, 0, 0)
                .ScaleHeight 1, msoTrue
                .ScaleWidth 1, msoTrue
            End With
        End If
    Next i
    
    '新しいメンバーのポケモンの育成論のURL("の育成論を見る"の文字列が含まれているaタグ))を抽出
    Dim objLink As Object
    
    For Each objLink In ieObject.document.Links
        If InStr(objLink.outerHTML, pokemonName & "の育成論を見る") > 0 Then
            newMemberSheet.Range("B2").Value = objLink
            Exit For
        End If
    Next
        
    '新しいメンバーのポケモンの覚える技、タマゴ技の文字列、遺伝経路のURL("遺伝経路"の文字列が含まれているaタグ)を抽出
    Dim j As Integer
    j = 1
    Dim k As Integer
    k = 3
    Dim l As Integer
    l = 3
    Dim objLink2 As Object
    
    With newMemberSheet
        For Each objLink2 In ieObject.document.Links
            If InStr(objLink2, "move=") > 0 Then
                 .Range("E" & k).Value = ieObject.document.Links(j).outerText
                 k = k + 1
                If InStr(ieObject.document.Links(j).outerHTML, "遺伝経路") > 0 Then
                    .Range("H" & l).Value = objLink2
                    .Range("G" & l).Value = ieObject.document.Links(j + 1).outerText
                    l = l + 1
                End If
            End If
            j = j + 1
        Next
    End With
End Sub

#サンプル画像と使用例
以下の手順で作成してほしい。
1.Excelブックを新規作成する。
2.Excelブックのシート名を「メインシート」に変更する。
3.以下画像の通り、ボタンを配置する。A1:G2をセル結合し、タイトルを入力。また、C4:D4をセル結合し、B4に「ポケモン名:」と入力。こうしないと、マクロが機能しない。なお、登録するマクロ名は『btnTeamMake_click()』とし、コードは上記のコードをコピペするものとする。

4.以下画像の通り、テンプレートシートを作成する。(個人的に)重要なのは、B5:C16、E1:E2、G1:H2だ。そのため、それらの箇所は、画像の通り入力してほしい。
なお、シート名は「テンプレート」とする。

・テンプレートシート

5.こうしてボタンを押すと、以下画像の通り、ポケモンのデータが出力されたシートが出来上がる。
・実行結果の一例

#終わりに
VBA超初心者の方が事前準備なしに実際に作っていくとなると、かなり苦労するだろう。(具体的に、作成には5時間ほどかかると思われる)
なので、拙作のコードを以って、うまく応用していただきたい。
業務でもスクレイピングを使うこともあるだろうし、趣味のソシャゲのデータをスクレイピングしたいときもあるだろう。
その時にこの記事を思い出してくれると、嬉しいことこの上ない。
#参考にしたサイト
・VBA コーディングガイドライン
・VBAのIE制御入門

#追記(2020/4/08)
この記事をご覧になった方は、VBAでも手軽にスクレイピングをできるじゃない！と思われただろう。
確かに、VBAでスクレイピングを行うのは比較的容易だ。しかし、思わぬ落とし穴も存在する。
それは、『汎用性が低い』ことだと、筆者は考えている。
上記の点は、VBAに限らず、pythonやjavascriptといったメジャーな言語でも同じことが言えるが、VBAの場合は、InternetExplorerプロパティの仕様のためだと考えている。
例えは、以下のコードをご覧いただきたい。

For i = 1 To ieObject.document.getElementsByClassName("left").Length
        With newMemberSheet
            Select Case i
                Case 1
                    .Range("C11").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                    .Range("C7").Value = ieObject.document.getElementsByTagName("li")(i).innerText
                Case 2
                    .Range("C12").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                    .Range("C8").Value = ieObject.document.getElementsByTagName("li")(i).innerText
                Case 3
                    .Range("C13").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                Case 4
                    .Range("C14").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                Case 5
                    .Range("C15").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                Case 6
                    .Range("C16").Value = ieObject.document.getElementsByClassName("left")(i).innerText
                Case Else

            End Select
        End With

        '新しいメンバーのポケモンの画像を取得(新しいメンバーの名前が含まれているimgタグ)、シートに貼り付け
        If ieObject.document.images(i).alt = pokemonName Then
            With newMemberSheet.Shapes.AddPicture(ieObject.document.images(i).src, True, False, Selection.Left, Selection.Top, 0, 0)
                .ScaleHeight 1, msoTrue
                .ScaleWidth 1, msoTrue
            End With
        End If
    Next i

上記のコードで、

ieObject.document.getElementsByClassName("left")(i).innerText

とあるが、これはi番目の、クラス名がliftであるタグのテキストを出力するというコードである。このように記述するには、該当のサイトでF12キーを押下しHTMLを読み解くしかない。そこが面倒といえば面倒で、落とし穴になる。場合によっては、5番目のクラス名がtestのh5タグのテキストを抽出するといったように、直に場所を指定しなければならないこともままある。
長々と駄文を書き綴ったが、要は「スクレイピングには該当のサイトでF12キーを押下しHTMLを読み解くことが不可欠」ということを伝えたかっただけだ。
そのやり方は、本記事の趣旨に外れるので記載は控える。興味がある方は、まずは自力で調査することをお勧めする。

You get articles that match your needs
You can efficiently read back useful information
You can use dark theme

What you can do with signing up