Boolean Effect

VBAでスクレイピング　タグをリスト化し検索文字列でセルに色付け

スクレイピングアプリを作るとき、例えばTDタグを一覧にして「次のページ」が何番目のタグに入っているか調べたい時があります。ということでVBAで任意のタグ一覧を抽出しリスト化その中で文字列検索しその文字が含まれていればセルに色を付けるマクロを作成しました。

以下の表をSheet1のA1にコピペしてください

次のコードをマクロに記述してください

Option Explicit

'IE を 起動してタグを抽出する
Sub tagscraping()

Dim objIE    As Object  'ＩＥオブジェクト参照用
Set objIE = CreateObject("InternetExplorer.application") 'IEのオブジェクトを作る
    objIE.Visible = True '見えるようにする(お約束)

Dim URLst As String
Dim Tag As String
    URLst = ThisWorkbook.Worksheets(1).Range("D1").Value
    
    
    '.Navigate で 指定した文字列のURLを開く
    objIE.Navigate URLst
      
    Dim maxrow As Integer
    
    '最下の行を取得　空白OK
    With ActiveSheet.UsedRange
        maxrow = .Rows(.Rows.Count).Row
        'MaxCol = .Columns(.Columns.Count).Column
    End With
    
    If maxrow <> 1 Then
    '行の削除
    'MsgBox ("2:" & maxrow)
        Range("2:" & maxrow).Clear
    End If
    
    'ページの表示完了を待ちます。
    While objIE.ReadyState <> 4 Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '.tags("TD") で TDタグを抜き出す
    Dim objTD As Object 'テーブルオブジェクトの格納用
    
    
    
    Tag = ThisWorkbook.Worksheets(1).Range("B1").Value
    
    Select Case Tag
        Case "td", "TD"
            Set objTD = objIE.document.all.tags("TD")
        Case "a", "A"
            Set objTD = objIE.document.all.tags("A")
        Case "img", "IMG"
            Set objTD = objIE.document.all.tags("IMG")
        Case "div", "DIV", "Div"
            Set objTD = objIE.document.all.tags("DIV")
        Case "Span", "span", "SPAN"
            Set objTD = objIE.document.all.tags("SPAN")
        Case "", "all"
            Set objTD = objIE.document.all
    End Select
    

    

    ActiveSheet.Name = "タグを抜くテスト"  'シートに名前を付ける
    
    'TDデータをシートに貼り付ける
    
    
    Range("A2") = "変数n"   '見出しをつける
    Range("B2") = ".InnerHTML"   '見出しをつける
    Range("C2") = ".InnerTEXT"   '見出しをつける
    Range("D2") = ".OuterHTML"   '見出しをつける
    
    'いろいろなループを作れるけど、カウンタ n でまわしてみる
    Dim n As Integer
    For n = 0 To objTD.Length - 1  'カウンタ０から.length - 1 までまわす。
        Cells(n + 3, "A") = n   'n+3行目にセット
        Cells(n + 3, "B") = "'" & Left(objTD(n).InnerHTML, 500)  'デバック用に左から80文字までセット
        Cells(n + 3, "C") = "'" & Left(objTD(n).InnerTEXT, 500)   'デバックなのでシングルコーテーションを付け
        Cells(n + 3, "D") = "'" & Left(objTD(n).OuterHTML, 500)   '文字列扱いでセットする
    Next n

    '後始末(使った食器はキレイにしてから戸棚に戻そうね)
    Set objTD = Nothing
    
    objIE.Quit    '今回はコメントにして処理しない(残しておいた方がテスト時は楽です)
    Set objIE = Nothing
    
    '------検索文字のセルに色を付ける-----------
    Dim MyBottom As Long
    Dim c As Range
    Dim firstAddress As String
    Dim Myfindstr As String
    
    '空白でないならセル色付けを呼ぶ
    If Not (ThisWorkbook.Worksheets(1).Range("F1").Value = "") Then
     
         Myfindstr = ThisWorkbook.Worksheets(1).Range("F1").Value
      
        '最下の行を取得 空白OK
        With ActiveSheet.UsedRange
            maxrow = .Rows(.Rows.Count).Row
            'maxCol = .Columns(.Columns.Count).Column
        End With


        With Range("B2:D" & maxrow)
            Set c = .Find("*" & Myfindstr & "*", LookIn:=xlValues)
            If Not c Is Nothing Then
               firstAddress = c.Address
                Do
                   With c.Interior
                    .ColorIndex = 6
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    End With
                    Set c = .FindNext(c)
               Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With
    
    End If '空白でないならセル色付けを呼ぶのendif
    
    
End Sub

AB型の変わり者 三流プログラマー Ken3のＨＰ様のコードをベースにさせて頂きました。

実行結果

サンプルではヤフーのページをTDタグで抜き出しリスト化、その中にyahooの文字列が入っているセルを黄色にします。

参考リンク Spcial thanks

AB型の変わり者 三流プログラマー Ken3のＨＰ様　　VBAでスクレイピングするならおすすめのページです。