人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

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

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


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

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

●質問者: uchisuke
●カテゴリ:インターネット ウェブ制作
✍キーワード:Excel Google URL VBA イメージ
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● todo36
●15ポイント

http://www.unisys.co.jp/club/net_view/20030214.html

◎質問者からの返答

ありがとうございます。

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

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

やってみます。


2 ● NeiM
●75ポイント

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

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

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

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


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

◎質問者からの返答

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

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

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

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


3 ● gong1971
●100ポイント ベストアンサー

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列にデータがある限り検索を続けます。


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

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


4 ●
●75ポイント

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での対応方法まで調べ切れませんでした。)

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ