VBA(Excel マクロ)でiタウンページデータを取得

営業系の会社などは、テレアポリストの作成に困るケースも多々あるかと思います。その時、企業リストを作成するのに手軽なのはなんといっても「iタウンページ」。今回はiタウンページからのデータ抽出をVBAを使って簡単に行う方法を紹介します。

利用手順

本サンプルの利用方法は以下の通りです。

以下のVBAをExcelのVBAに貼り付け
「IE_kidou」関数を実行して、iタウンページをインターネットエクスプローラーで表示
前項で表示されたiタウンページ内を適宜検索し、抽出したい一覧を表示する
「listka」関数を実行し、表示内容をリスト化

IE起動関数(VBA)

' vba でIEを起動する
Sub IE_kidou()
    
    'インターネットエクスプローラーのオブジェクトを作る
    Set objIE = CreateObject("InternetExplorer.application")
    
    '見えるようにする
    objIE.Visible = True
    
    '文字列で指定したＵＲＬに遷移
    objIE.Navigate "https://itp.ne.jp"
    
    '表示終了まで待つ
    Do While objIE.Busy = True
        DoEvents
    Loop
   
End Sub

【解説】

このVBAは、IEに表示された内容を取得し社名や電話番号の部分だけをうまく抽出するロジックを入れています。そのため、まずはIEを起動する必要があります。

リスト化関数(VBA)

Sub listka()
    
    Dim ObjShell As Object
    Dim ObjWindow As Object
    Dim WinExist As Boolean
    
    ' 起動中のIEを取得し、objIEにセット
    WinExist = False
    Set ObjShell = CreateObject("Shell.Application")
    For Each ObjWindow In ObjShell.Windows
        If TypeName(ObjWindow.Document) = "HTMLDocument" Then
          WinExist = True
          Set objIE = ObjWindow
        End If
    Next
    Set ObjShell = Nothing
        
    ' 最終行を取得
    insert_row = Cells(Range("A1").SpecialCells(xlLastCell).Row + 1, 1).End(xlUp).Row
    result_flg = False   
    
    'とりあえず5ページ目まで取得するサンプル
    For i = 1 To 5
        
        ' 全てのタグを確認
        For Each objTAG In objIE.Document.all
            
            ' articleタグ以降が取得対象
            If objTAG.tagName = "ARTICLE" Then
                result_flg = True
            End If
    
            ' 以下条件に合致したら当該ページのデータ取得は終了
            If objTAG.tagName = "DIV" And objTAG.className = "bottomNav" Then
                result_flg = False
                next_flg = True
            End If
            
            If result_flg = True Then    
                ' 名称取得
                If objTAG.tagName = "H4" Then
                    insert_row = insert_row + 1
                    Cells(insert_row, 1) = objTAG.innerText
                End If
            
                ' 住所や電話番号等の取得
                If objTAG.tagName = "P" Then
                    
                    If Left(objTAG.innerText, 2) = "住所" Then
                        ' 郵便番号と住所を分離してセット
                        temp_val = Replace(objTAG.innerText, "住所 ", "")
                        temp_val = Replace(temp_val, " 地図・ナビ", "")
                        Cells(insert_row, 2) = Left(temp_val, 9)
                        Cells(insert_row, 3) = Mid(temp_val, 11)
                    
                    ElseIf Left(objTAG.innerText, 3) = "TEL" Then
                        ' TEL
                        temp_val = Replace(objTAG.innerText, "TEL ", "")
                        Cells(insert_row, 4) = temp_val
                    
                    ElseIf Left(objTAG.innerText, 3) = "URL" Then
                        ' URL
                        temp_val = Replace(objTAG.innerText, "URL ", "")
                        Cells(insert_row, 5) = temp_val
                    
                    ElseIf Left(objTAG.innerText, 5) = "EMAIL" Then
                        ' EMAIL
                        temp_val = Replace(objTAG.innerText, "EMAIL ", "")
                        Cells(insert_row, 6) = temp_val
                    
                    End If
                End If
            End If

            'ページネーションのリンク先を取得し、次のページのURLを取得        
            If next_flg = True Then
                If objTAG.tagName = "A" And objTAG.innerText = "次へ" Then
                    next_url = objTAG.href
                    Exit For
                End If
            End If
        
        Next

        '次のページへ
        objIE.Navigate next_url

        '表示終了まで待つ
        Do While objIE.Busy = True
            DoEvents
        Loop
        
    Next i
    
End Sub