EXCEL+インターネットについて質問です。


セルA、セルB、セルCそれぞれに入力された文字列を、絞込み条件としGoogle等の検索エンジンに投げ、検索結果上位1位のURLをセルDに自動入力させたいと思っています。
(その処理を行数分繰り返して欲しいです)

上記のようなVBA等が載っているサイトはありますでしょうか?


あまり詳しい訳ではないので、参考情報だけでは困ります。
ドンピシャなものがあればうれしいです。
よろしくお願い致します。

できればイメージ検索の画像URLとかも抜けるとありがたいですが・・・。
言いすぎですね。

回答の条件
  • URL必須
  • 1人2回まで
  • 登録:2006/06/17 12:01:56
  • 終了:2006/06/24 09:16:44

ベストアンサー

id:gong1971 No.3

gong1971回答回数443ベストアンサー獲得回数682006/06/20 16:30:24

ポイント100pt

2 のNeiMさんが作成されたVBAだとヒット数を求めてますが、

求めたいのは1つ目のurlですよね?面白そうなので作ってみました。

http://www.geocities.jp/gong1971/IEsearch.html


A列、B列、C列の2行目以降にキーワードを入力し、

D1のボタンをクリックするとD列にWeb検索の1つ目のurlが、

E1のボタンをクリックするとE列にイメージ検索の2つ目のurlが

表示されます。A列にデータがある限り検索を続けます。


ささっと作ったので間違えがあったらゴメンなさい。

こちらの環境では正常に動作しています。

その他の回答(3件)

id:todo36 No.1

todo36回答回数34ベストアンサー獲得回数52006/06/17 13:24:10

id:uchisuke

ありがとうございます。

少しづつやってみたりしているのですが、

本題に行くまでに色々と・・・。

やってみます。

2006/06/20 06:21:00
id:NeiM No.2

NeiM回答回数2ベストアンサー獲得回数02006/06/19 23:43:51

ポイント75pt

http://impronote.sakura.ne.jp/cms/blog/2006/06/post_4.html

自分で作ってみたものですが参考になれば幸いです。

ぶっちゃけ、初めて書いたのでぐちゃぐちゃだったりして・・・

綺麗ところは、コピペしてきたとこです^^;


おそらくは、todo36さんが教えてくださってる方法が一番いいと思われます。やや敷居がたかそうですけどね

id:uchisuke

わざわざ作って頂いたのですか!

ありがとうございます!!

しかと、拝見させていただきます。

ありがとうございました。

2006/06/20 06:21:50
id:gong1971 No.3

gong1971回答回数443ベストアンサー獲得回数682006/06/20 16:30:24ここでベストアンサー

ポイント100pt

2 のNeiMさんが作成されたVBAだとヒット数を求めてますが、

求めたいのは1つ目のurlですよね?面白そうなので作ってみました。

http://www.geocities.jp/gong1971/IEsearch.html


A列、B列、C列の2行目以降にキーワードを入力し、

D1のボタンをクリックするとD列にWeb検索の1つ目のurlが、

E1のボタンをクリックするとE列にイメージ検索の2つ目のurlが

表示されます。A列にデータがある限り検索を続けます。


ささっと作ったので間違えがあったらゴメンなさい。

こちらの環境では正常に動作しています。

id:bonlife No.4

回答回数421ベストアンサー獲得回数752006/06/20 17:12:32

ポイント75pt

2番目のid:NeiMさんの回答をベースにA列、B列、C列の値で絞り込んだGoogleでの検索結果の1つ目のURLをD列に表示するVBAを書いてみました。

適当なEXCELシートに標準モジュールを追加して下記の内容を貼り付けてAlt+F8などから実行してみてください。

(ソースはあまり整理されておりませんが、一応私の環境では動きました。)

あえてUTF-8に変換しなくてもGoogleの検索自体は実行できますので、Shift-JISのまま処理するサンプルにしてみました。

[参考URL]

オマケでE列にハイパーリンクを表示させるようにしております。

Sub HTTP_Google()
    Dim IEObject As Object
    Dim i As Integer ' ループ用変数
    Dim j As Integer ' ループ用変数
    Dim targetColumn As Integer ' 検索対象とする列 (1列目からtargetColumnまでを対象とする)
    Dim urlResultColumn As Integer ' 結果のURLを表示させる列
    Dim resultColumn As Integer ' 結果(ハイパーリンク)を表示させる列
    Dim searchStr As String
    targetColumn = 3
    urlResultColumn = 4
    resultColumn = 5
    Set IEObject = CreateObject("InternetExplorer.application")
    ' 検索対象の列がブランクでない間、繰り返し処理を実行
    i = 1
    While Cells(i, 1).Value <> ""
        searchStr = "" ' 初期化
        j = 1
        ' 検索語句の作成 (1列目からtargetColumn列まで結合)
        While j <= targetColumn
            searchStr = searchStr & " " & Cells(i, j).Value
            j = j + 1
        Wend
        searchStr = Trim(searchStr)
        Dim GoogleSearchUrl As String ' Google検索URL
        Dim HTMLResult As String ' Google検索結果HTML
        GoogleSearchUrl = "http://www.google.com/search?hl=ja&lr=lang_ja&ie=Shift-JIS&oe=Shift-JIS&num=1&q=" + UrlEncodeP(searchStr)
        IEObject.Navigate (GoogleSearchUrl)
        ' 処理待ち
        While (IEObject.busy): Wend
        While (IEObject.document.readyState <> "complete"): Wend
        HTMLResult = IEObject.document.body.innerHtml
        ' 下記で定義するGoogle1stResultUrlGetを呼び出し、結果表示列に値をセット
        Cells(i, urlResultColumn).Value = Google1stResultUrlGet(HTMLResult)
        ' タイトルを取得し、そこにリンクを貼り付ける
        Cells(i, resultColumn).Value = Google1stResultTitleGet(HTMLResult)
        Cells(i, resultColumn).Select
        With ActiveSheet
            .Hyperlinks.Add Anchor:=Selection, Address:=Google1stResultUrlGet(HTMLResult)
        End With
        i = i + 1
Wend
End Sub
Public Function Google1stResultUrlGet(strHTML As String) As String
    ' 変数定義
    Dim fromPosition As Integer ' 結果取得開始位置
    Dim cutLength As Integer ' 取得する文字列長
    Dim searchStart As String ' 取得対象の始まりを特定するための文字列
    Dim searchEnd As String ' 取得対象の終了を特定するための文字列
    searchStart = "<A class=l onmousedown=""return clk(this.href,'','','res','1','')"" href="""
    searchEnd = """>"
    fromPosition = InStr(strHTML, searchStart)
    If (fromPosition = 0) Then
        Google1stResultUrlGet = "NO RESULT"
    Else
        fromPosition = fromPosition + Len(searchStart)
        cutLength = InStr(fromPosition, strHTML, searchEnd) - fromPosition
        Google1stResultUrlGet = (Mid(strHTML, fromPosition, cutLength))
    End If
End Function
Public Function Google1stResultTitleGet(strHTML As String) As String
    ' 変数定義
    Dim fromPosition As Integer ' 結果取得開始位置
    Dim cutLength As Integer ' 取得する文字列長
    Dim searchStart As String ' 取得対象の始まりを特定するための文字列
    Dim searchEnd As String ' 取得対象の終了を特定するための文字列
    searchStart = "<A class=l onmousedown=""return clk(this.href,'','','res','1','')"" href="""
    searchEnd = "</A>"
    fromPosition = InStr(strHTML, searchStart)
    fromPosition = InStr(fromPosition, strHTML, ">") + Len(">")
    If (fromPosition = 0) Then
        Google1stResultTitleGet = "NO RESULT"
    Else
        cutLength = InStr(fromPosition, strHTML, searchEnd) - fromPosition
        Google1stResultTitleGet = (Mid(strHTML, fromPosition, cutLength))
        ' 強調用の<B>、</B>を削除
        Google1stResultTitleGet = Replace(Google1stResultTitleGet, "<B>", "")
        Google1stResultTitleGet = Replace(Google1stResultTitleGet, "</B>", "")
    End If
End Function
Public Function UrlEncodeP(ByVal strSource As String) As String
'
' 公開されている関数を利用させていただきました。
'
' TITLE : 三流君VBA:URLのエンコード関数を作成する
' URL   : http://www.ken3.org/vba/backno/vba143.html
'
    ' パラメータのエンコード
    Dim s As String
    Dim lngCode As Long
    Dim i As Long
    UrlEncodeP = "" ' 初期化
    For i = 1 To Len(strSource)
        s = Mid(strSource, i, 1)    ' 一文字目を取り出し
        lngCode = Asc(s) And &HFFFF& ' マスクする
        If lngCode = &H20 Then  ' スペースか?
            ' 空白文字
            s = "+"    ' 空白記号の+へ変更
        ElseIf lngCode >= &H100 Then ' 2バイト文字か?
            ' 全角文字コード変換
            s = Right("00" & Hex(lngCode), 4)
            s = "%" & Left(s, 2) _
              & "%" & Right(s, 2)
        ElseIf Not s Like "[0-9A-Za-z*._-]" Then
            ' 半角記号
            s = "%" & Right("0" & Hex(lngCode), 2)
        End If
        UrlEncodeP = UrlEncodeP & s
    Next
End Function

参考になれば幸いです。

以下、補足です。

イメージ検索についてはちょっと私には難しすぎて対応できませんでした。

また、1番目のid:todo36さんの回答にあるやり方を私も試してみたのですが、以下のようなエラーが出てうまく動きませんでした。

No Deserializer found to deserialize a ':key' using encoding style 'http://schemas.xmlsoap.org/soap/encoding/'.

生成されるXML中にxsiが指定されていないことが原因のようですね。

同様の現象が多数報告されていました。

(が、EXCEL VBAでの対応方法まで調べ切れませんでした。)

コメントはまだありません

この質問への反応(ブックマークコメント)

トラックバック

  • はてなに挑戦 いんぷろのーと 2006-06-19 23:33:42
    Perl勉強中なんですが、気まぐれではてなの質問に答えてみます EXCEL+イン...
「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません