三栄ＮＡＶＩの中で、エクセルのＷｅｂ情報取込み機能を紹介した事があります。

ＵＲＬを指定して、その内容をエクセルに取り込みが込む機能があります。
この機能を使って、ＶＢＡスクリプトでＷｅｂからの情報取得を自動化すると言うような話でした。
この手法は、色々使えるとお話ししましたが、ｉタウンページでは、Ｗｅｂ画面を取り込む事が出来ません。
前は出来ていたのです。と言う事もお話ししました。
どの様な方法で出来なくしているのかはわかりませんが、住所データですので、防御しているのでしょう。

最近、ある職種のデータを集めたいと思う事があり、久しぶりに　ｉタウンページを除きました。 

タウンページ画面

先ほどお話しした通り、自動化は、出来ません。
検索結果をコピー＆ペースト作業を手作業で行う事としました。

検索

今回の例では、場所に品川、目的にカルチャーで検索しました。

検索結果では、８１件ヒットしてます。
表示数を最大の５０件で行いました。

コピー

中央に表示される検索結果だけをコピーします。

ペースト

エクセルにペースト

検索結果が、複数ページになった場合は、それぞれをエクセルに追加コピーします。

大量の場合は、手作業はきついと思いますが、根気よく実行するしかありません。 

正規化マクロを実行

iタウンページ取込みデータ正規化
マクロは、最後に紹介してます。

シート２に住所リストが出来上がりました。

 この住所データを何に使うのですか・・・・・？

 iタウンページ取込みデータ正規化　マクロ

 次のスクリプトをコピーして、マクロに登録して使用してみてください。
すべての検索結果を行ったわけではありませんので、多少不具合があるかもしれません。
使う場合には、自己責任で行ってください。

Sub iタウンページ取込みデータ正規化()
  
        行データ有無フラグ = 1
        st_gyou = 1
        gyou_end = 1
        write_gyo = 1
        outA = 1
        tretu = 1 '検索の列番号に書き換えてください
        naiyo = "お気に入りに登録" '検索文字列に書き換えてください
        ifrag = 0

        Do While 行データ有無フラグ = 1
        
            BB = Sheet1.Cells(st_gyou, 1) 'データを読み込む
            If Not BB = "" Then
                If InStr(BB, naiyo) >= 1 Then
                    Sheet2.Cells(write_gyo, outA + 0) = write_gyo
                    
                    For a = 1 To ifrag - 1 Step 1
                        cc = Sheet1.Cells(st_gyou - a, tretu)
                        If Left(cc, 3) = "TEL" Then
                            Sheet2.Cells(write_gyo, outA + 4) = Replace(cc, "TEL", "")
                        Else
                                 If Left(cc, 3) = "URL" Then
                                        cc = Replace(cc, "URL", "")
                                        Sheet2.Cells(write_gyo, outA + 6) = cc
                                 Else
                                        If Left(cc, 5) = "EMAIL" Then
                                                cc = Replace(cc, "EMAIL", "")
                                                Sheet2.Cells(write_gyo, outA + 5) = cc
                                        Else
                                                If Left(cc, 2) = "住所" Then
                                                    cc = Replace(cc, "住所", "")
                                                    cc = Replace(cc, "地図・ナビ", "")
                                                    sac = InStr(cc, "　")
                                                    cc1 = Mid(cc, 1, sac - 1)
                                                    cc2 = Mid(cc, sac + 1)
                                                    Sheet2.Cells(write_gyo, outA + 2) = cc1
                                                    Sheet2.Cells(write_gyo, outA + 3) = cc2
                                                Else
                                                    cc = Replace(cc, "付加価値情報", "")
                                                    Sheet2.Cells(write_gyo, outA + 1) = cc
                                               End If
                                        End If
                                End If
                        End If
                    Next
                    
                    write_gyo = write_gyo + 1
                    
                    ifrag = 0
                Else

                End If
                    If st_gyou = 1 Then
                           ifrag = ifrag + 1
                    End If
                    ifrag = ifrag + 1
                    st_gyou = st_gyou + 1
            Else
            
                 行データ有無フラグ = 0

            End If

        Loop

End Sub