エクセルの機能にＷｅｂデータの取得機能がある事を知ったのはつい最近です。
この年になって、今更勉強なんてなかなかできませんが、色々と使ってみました。
そして、スクリプトを組んで使うと結構面白い事が出来そうです。

参考になりそうなので、紹介します。

Ｗｅｂクエリを使って見る。

ＵＲＬを　入力します。
http://www.e-hon.ne.jp/bec/SE/List?dcode=01&ccode=02&scode=01&Genre_id=010201&listcnt=0

ＵＲＬのサイトが表示されます
読み込む位置を指定します。

データが読み込まれました。

この一連の手順をスクリプト化して、読み込まれた　情報から必要事項を抜き出す事で何か出来ないかと言う事です。
？・・・・

Webサイトには、情報の検索サイトが多くあります。
価格ドットコム、アマゾン、楽天、ヤフーなどの商品や話題のトップテン情報などを検索できます。
これら情報をデータとして取り込む事が出来れば色々な事に使えるのではと思います。
色々・・って　？
あなたも考えて見てください。

完全自動化とは行きませんが、ここでは、全国書店ネットワーク　e-hon　を例に紹介します。

このサイトは、新書をカテゴリー別に紹介しており、定期的に覗いて情報を入手できます。

新刊のリストを取得するスクリプトを書いてみました。

ボタンのオンで実行するようにします。

ボタンにスクリプトを割り当て、記入します

スクリプトの流れ

検索ＵＲＬは、シート３にリスト化します。
ＵＲＬリストを使用して、Ｗｅｂからの情報をシート１に読み込みます。
読み込んだ、情報から必要部分を抜き出して、シート２に書き出します。

Webクエリマクロ

 Ｗｅｂクエリのスクリプト部分は、実際にWebクエリを動かしマクロ記録機能でトレースしたものを関数に書き換えました。

Function Macro2(urlaa)
   'With ActiveSheet.QueryTables.Add(Connection:=urlaa, Destination:=Range("$A$1"))
    With ActiveSheet.QueryTables.Add(Connection:= _
        urlaa, Destination:=Range _
        ("$A$1"))
   
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False

    End With
End Function

 シート１のデータを読み込んだ状態

シート1の読み込んだデータの規則性を見つけ、スクリプトで、必要な部分を抜き取り、シート２に書き出しました。
この部分が、Ｗｅｂ毎に異なります。

このスクリプトでは、読み込むＵＲＬは、シート３にリスト化してます。

リストが無くなるまで繰り返すようにしてます。

なんで、この様な目的もはっきりしないスクリプトをと思う方もいらっしゃるかもしれません。
例えば、、ペットショップの住所録を作る為に行いました。
タウンページから、特定業界のリスト化に使う事が出来たのです。

しかし、原因はわかりませんが、今は、Ｗｅｂクエリから情報の取得はできないようです。
それでも、使いようによっては、面白い事が出来そうです。

スクリプト全体です。

Private Sub CommandButton1_Click()

    Dim st_gyou, 行データ有無フラグ, 列データ有無フラグ
    Dim retsu_CT, gyou_end, retu_end
    Dim AA, BB
    Dim tretu, naiyo, write_gyo
    Dim sp, sss1, sss2
    Dim urlac, urlad
    Dim pageA, pageend, pagecunt
    Dim daimoku, jyuniNo
    Dim ifrag, psgyofg, psdataA, psdataB
    Dim endflg
    Dim URLA1, URLB1, kensakURL, URLFKAG
    Dim 年月日Fg
    
    retsu_CT = 11
    retu_end = 1
    
    列データ有無フラグ = 1
    write_gyo = 1

    Macro3

    URLFKAG = 1
    URLA1 = 2
    URLB1 = 1

    Do While URLFKAG = 1
        daimoku = Sheet3.Cells(URLA1, URLB1)
        kensakURL = Sheet3.Cells(URLA1, URLB1 + 1)
        jyuniNo = 1
        pagecunt = 1
        psdataA = "1"
        psdataB = "2"
        endflg = 0
        sss1 = 0
        sss2 = 0
        outA = 2
    
        urlac = "URL;" & kensakURL

        Macro2 (urlac)
   
        gyou_end = 1
        行データ有無フラグ = 1
        st_gyou = 26
        tretu = 8  '検索の列番号に書き換えてください
        naiyo = "「満足度」" '検索文字列に書き換えてください
    
        ifrag = 0

        Do While 行データ有無フラグ = 1
            BB = Sheet1.Cells(st_gyou, tretu) 'データを読み込む
            If Not BB = "" Then
        
                Sheet2.Cells(write_gyo, outA - 1) = daimoku
        
                If "内容" = Sheet1.Cells(st_gyou + 7, tretu - 2) Then
        
                    Sheet2.Cells(write_gyo, outA) = Sheet1.Cells(st_gyou, tretu) & " " & Sheet1.Cells(st_gyou + 1, tretu)
                    AA = Sheet1.Cells(st_gyou + 2, tretu)
                    AA = Replace(AA, "／著", "")
                    Sheet2.Cells(write_gyo, outA + 1) = AA
                    Sheet2.Cells(write_gyo, outA + 2) = Sheet1.Cells(st_gyou + 3, tretu)
                    Sheet2.Cells(write_gyo, outA + 3) = Sheet1.Cells(st_gyou + 4, tretu)
                    Sheet2.Cells(write_gyo, outA + 4) = Sheet1.Cells(st_gyou + 8, tretu - 2)
                Else
                
                    Sheet2.Cells(write_gyo, outA) = Sheet1.Cells(st_gyou, tretu)
                    AA = Sheet1.Cells(st_gyou + 1, tretu)
                    AA = Replace(AA, "／著", "")
                    Sheet2.Cells(write_gyo, outA + 1) = AA
                    Sheet2.Cells(write_gyo, outA + 2) = Sheet1.Cells(st_gyou + 2, tretu)
                    Sheet2.Cells(write_gyo, outA + 3) = Sheet1.Cells(st_gyou + 3, tretu)
                    Sheet2.Cells(write_gyo, outA + 4) = Sheet1.Cells(st_gyou + 7, tretu - 2)
                End If
              
                write_gyo = write_gyo + 1
                sss1 = 0
                st_gyou = st_gyou + 7
                gyou_end = gyou_end + 7
            Else
                sss1 = sss1 + 1
                st_gyou = st_gyou + 1
            End If
        
            If sss1 >= 8 Then
                行データ有無フラグ = 0
            End If
        Loop

        Macro1
        URLA1 = URLA1 + 1
        If Sheet3.Cells(URLA1, URLB1) = "" Then
            URLFKAG = 0

        End If
    Loop

End Sub

Function Macro2(urlaa)
   'With ActiveSheet.QueryTables.Add(Connection:=urlaa, Destination:=Range("$A$1"))
    With ActiveSheet.QueryTables.Add(Connection:= _
        urlaa, Destination:=Range _
        ("$A$1"))
   
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False

    End With

End Function


Sub Macro1()
    Columns("A:I").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
End Sub

Sub Macro3()
    Sheets("Sheet1").Select
    Range("A1").Select
End Sub